module Distribution.Simple.Program (
Program(..)
, simpleProgram
, findProgramOnPath
, findProgramVersion
, ConfiguredProgram(..)
, programPath
, ProgArg
, ProgramLocation(..)
, rawSystemProgram
, rawSystemProgramStdout
, builtinPrograms
, ProgramConfiguration
, emptyProgramConfiguration
, defaultProgramConfiguration
, restoreProgramConfiguration
, addKnownProgram
, addKnownPrograms
, lookupKnownProgram
, knownPrograms
, userSpecifyPath
, userSpecifyPaths
, userMaybeSpecifyPath
, userSpecifyArgs
, userSpecifyArgss
, userSpecifiedArgs
, lookupProgram
, updateProgram
, configureProgram
, configureAllKnownPrograms
, reconfigurePrograms
, requireProgram
, rawSystemProgramConf
, rawSystemProgramStdoutConf
, ghcProgram
, ghcPkgProgram
, nhcProgram
, hmakeProgram
, jhcProgram
, hugsProgram
, ffihugsProgram
, gccProgram
, ranlibProgram
, arProgram
, stripProgram
, happyProgram
, alexProgram
, hsc2hsProgram
, c2hsProgram
, cpphsProgram
, hscolourProgram
, haddockProgram
, greencardProgram
, ldProgram
, tarProgram
, cppProgram
, pkgConfigProgram
) where
import Data.List (foldl')
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import Distribution.Simple.Utils
(die, debug, warn, rawSystemExit, rawSystemStdout)
import Distribution.Version
( Version(..), VersionRange(AnyVersion), withinRange )
import Distribution.Text
( simpleParse, display )
import Distribution.Verbosity
import System.Directory
( doesFileExist, findExecutable )
import Control.Monad (join, foldM)
import Distribution.Compat.Exception (catchExit, catchIO)
data Program = Program {
programName :: String,
programFindLocation :: Verbosity -> IO (Maybe FilePath),
programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),
programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
}
type ProgArg = String
data ConfiguredProgram = ConfiguredProgram {
programId :: String,
programVersion :: Maybe Version,
programArgs :: [ProgArg],
programLocation :: ProgramLocation
} deriving (Read, Show, Eq)
data ProgramLocation
= UserSpecified { locationPath :: FilePath }
| FoundOnSystem { locationPath :: FilePath }
deriving (Read, Show, Eq)
programPath :: ConfiguredProgram -> FilePath
programPath = locationPath . programLocation
simpleProgram :: String -> Program
simpleProgram name = Program {
programName = name,
programFindLocation = findProgramOnPath name,
programFindVersion = \_ _ -> return Nothing,
programPostConf = \_ _ -> return []
}
findProgramOnPath :: FilePath -> Verbosity -> IO (Maybe FilePath)
findProgramOnPath prog verbosity = do
debug verbosity $ "searching for " ++ prog ++ " in path."
res <- findExecutable prog
case res of
Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)
return res
findProgramVersion :: ProgArg
-> (String -> String)
-> Verbosity
-> FilePath
-> IO (Maybe Version)
findProgramVersion versionArg selectVersion verbosity path = do
str <- rawSystemStdout verbosity path [versionArg]
`catchIO` (\_ -> return "")
`catchExit` (\_ -> return "")
let version :: Maybe Version
version = simpleParse (selectVersion str)
case version of
Nothing -> warn verbosity $ "cannot determine version of " ++ path
++ " :\n" ++ show str
Just v -> debug verbosity $ path ++ " is version " ++ display v
return version
data ProgramConfiguration = ProgramConfiguration {
unconfiguredProgs :: UnconfiguredProgs,
configuredProgs :: ConfiguredProgs
}
type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])
type UnconfiguredProgs = Map.Map String UnconfiguredProgram
type ConfiguredProgs = Map.Map String ConfiguredProgram
emptyProgramConfiguration :: ProgramConfiguration
emptyProgramConfiguration = ProgramConfiguration Map.empty Map.empty
defaultProgramConfiguration :: ProgramConfiguration
defaultProgramConfiguration =
restoreProgramConfiguration builtinPrograms emptyProgramConfiguration
updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)
-> ProgramConfiguration -> ProgramConfiguration
updateUnconfiguredProgs update conf =
conf { unconfiguredProgs = update (unconfiguredProgs conf) }
updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)
-> ProgramConfiguration -> ProgramConfiguration
updateConfiguredProgs update conf =
conf { configuredProgs = update (configuredProgs conf) }
instance Show ProgramConfiguration where
show = show . Map.toAscList . configuredProgs
instance Read ProgramConfiguration where
readsPrec p s =
[ (emptyProgramConfiguration { configuredProgs = Map.fromList s' }, r)
| (s', r) <- readsPrec p s ]
restoreProgramConfiguration :: [Program] -> ProgramConfiguration
-> ProgramConfiguration
restoreProgramConfiguration = addKnownPrograms
addKnownProgram :: Program -> ProgramConfiguration -> ProgramConfiguration
addKnownProgram prog = updateUnconfiguredProgs $
Map.insertWith combine (programName prog) (prog, Nothing, [])
where combine _ (_, path, args) = (prog, path, args)
addKnownPrograms :: [Program] -> ProgramConfiguration -> ProgramConfiguration
addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs
lookupKnownProgram :: String -> ProgramConfiguration -> Maybe Program
lookupKnownProgram name =
fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs
knownPrograms :: ProgramConfiguration -> [(Program, Maybe ConfiguredProgram)]
knownPrograms conf =
[ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)
, let p' = Map.lookup (programName p) (configuredProgs conf) ]
userSpecifyPath :: String
-> FilePath
-> ProgramConfiguration -> ProgramConfiguration
userSpecifyPath name path = updateUnconfiguredProgs $
flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args)
userMaybeSpecifyPath :: String -> Maybe FilePath
-> ProgramConfiguration -> ProgramConfiguration
userMaybeSpecifyPath _ Nothing conf = conf
userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf
userSpecifyArgs :: String
-> [ProgArg]
-> ProgramConfiguration
-> ProgramConfiguration
userSpecifyArgs name args' =
updateUnconfiguredProgs
(flip Map.update name $
\(prog, path, args) -> Just (prog, path, args ++ args'))
. updateConfiguredProgs
(flip Map.update name $
\prog -> Just prog { programArgs = programArgs prog ++ args' })
userSpecifyPaths :: [(String, FilePath)]
-> ProgramConfiguration
-> ProgramConfiguration
userSpecifyPaths paths conf =
foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths
userSpecifyArgss :: [(String, [ProgArg])]
-> ProgramConfiguration
-> ProgramConfiguration
userSpecifyArgss argss conf =
foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss
userSpecifiedPath :: Program -> ProgramConfiguration -> Maybe FilePath
userSpecifiedPath prog =
join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs
userSpecifiedArgs :: Program -> ProgramConfiguration -> [ProgArg]
userSpecifiedArgs prog =
maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs
lookupProgram :: Program -> ProgramConfiguration -> Maybe ConfiguredProgram
lookupProgram prog = Map.lookup (programName prog) . configuredProgs
updateProgram :: ConfiguredProgram -> ProgramConfiguration
-> ProgramConfiguration
updateProgram prog = updateConfiguredProgs $
Map.insert (programId prog) prog
configureProgram :: Verbosity
-> Program
-> ProgramConfiguration
-> IO ProgramConfiguration
configureProgram verbosity prog conf = do
let name = programName prog
maybeLocation <- case userSpecifiedPath prog conf of
Nothing -> programFindLocation prog verbosity
>>= return . fmap FoundOnSystem
Just path -> do
absolute <- doesFileExist path
if absolute
then return (Just (UserSpecified path))
else findProgramOnPath path verbosity
>>= maybe (die notFound) (return . Just . UserSpecified)
where notFound = "Cannot find the program '" ++ name ++ "' at '"
++ path ++ "' or on the path"
case maybeLocation of
Nothing -> return conf
Just location -> do
version <- programFindVersion prog verbosity (locationPath location)
let configuredProg = ConfiguredProgram {
programId = name,
programVersion = version,
programArgs = userSpecifiedArgs prog conf,
programLocation = location
}
extraArgs <- programPostConf prog verbosity configuredProg
let configuredProg' = configuredProg {
programArgs = extraArgs ++ programArgs configuredProg
}
return (updateConfiguredProgs (Map.insert name configuredProg') conf)
configurePrograms :: Verbosity
-> [Program]
-> ProgramConfiguration
-> IO ProgramConfiguration
configurePrograms verbosity progs conf =
foldM (flip (configureProgram verbosity)) conf progs
configureAllKnownPrograms :: Verbosity
-> ProgramConfiguration
-> IO ProgramConfiguration
configureAllKnownPrograms verbosity conf =
configurePrograms verbosity
[ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf
where
notYetConfigured = unconfiguredProgs conf
`Map.difference` configuredProgs conf
reconfigurePrograms :: Verbosity
-> [(String, FilePath)]
-> [(String, [ProgArg])]
-> ProgramConfiguration
-> IO ProgramConfiguration
reconfigurePrograms verbosity paths argss conf = do
configurePrograms verbosity progs
. userSpecifyPaths paths
. userSpecifyArgss argss
$ conf
where
progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ]
requireProgram :: Verbosity -> Program -> VersionRange -> ProgramConfiguration
-> IO (ConfiguredProgram, ProgramConfiguration)
requireProgram verbosity prog range conf = do
conf' <- case lookupProgram prog conf of
Nothing -> configureProgram verbosity prog conf
Just _ -> return conf
case lookupProgram prog conf' of
Nothing -> die notFound
Just configuredProg
| range == AnyVersion -> return (configuredProg, conf')
Just configuredProg@ConfiguredProgram { programLocation = location } ->
case programVersion configuredProg of
Just version
| withinRange version range -> return (configuredProg, conf')
| otherwise -> die (badVersion version location)
Nothing -> die (noVersion location)
where notFound = programName prog ++ versionRequirement
++ " is required but it could not be found."
badVersion v l = programName prog ++ versionRequirement
++ " is required but the version found at "
++ locationPath l ++ " is version " ++ display v
noVersion l = programName prog ++ versionRequirement
++ " is required but the version of "
++ locationPath l ++ " could not be determined."
versionRequirement
| range == AnyVersion = ""
| otherwise = " version " ++ display range
rawSystemProgram :: Verbosity
-> ConfiguredProgram
-> [ProgArg]
-> IO ()
rawSystemProgram verbosity prog extraArgs
= rawSystemExit verbosity (programPath prog) (programArgs prog ++ extraArgs)
rawSystemProgramStdout :: Verbosity
-> ConfiguredProgram
-> [ProgArg]
-> IO String
rawSystemProgramStdout verbosity prog extraArgs
= rawSystemStdout verbosity (programPath prog) (programArgs prog ++ extraArgs)
rawSystemProgramConf :: Verbosity
-> Program
-> ProgramConfiguration
-> [ProgArg]
-> IO ()
rawSystemProgramConf verbosity prog programConf extraArgs =
case lookupProgram prog programConf of
Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found")
Just configuredProg -> rawSystemProgram verbosity configuredProg extraArgs
rawSystemProgramStdoutConf :: Verbosity
-> Program
-> ProgramConfiguration
-> [ProgArg]
-> IO String
rawSystemProgramStdoutConf verbosity prog programConf extraArgs =
case lookupProgram prog programConf of
Nothing -> die ("The program " ++ programName prog ++ " is required but it could not be found")
Just configuredProg -> rawSystemProgramStdout verbosity configuredProg extraArgs
builtinPrograms :: [Program]
builtinPrograms =
[
ghcProgram
, ghcPkgProgram
, hugsProgram
, ffihugsProgram
, nhcProgram
, hmakeProgram
, jhcProgram
, hscolourProgram
, haddockProgram
, happyProgram
, alexProgram
, hsc2hsProgram
, c2hsProgram
, cpphsProgram
, greencardProgram
, gccProgram
, ranlibProgram
, arProgram
, stripProgram
, ldProgram
, tarProgram
, pkgConfigProgram
]
ghcProgram :: Program
ghcProgram = (simpleProgram "ghc") {
programFindVersion = findProgramVersion "--numeric-version" id
}
ghcPkgProgram :: Program
ghcPkgProgram = (simpleProgram "ghc-pkg") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:_:_:_:ver:_) -> ver
_ -> ""
}
nhcProgram :: Program
nhcProgram = (simpleProgram "nhc98") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:('v':ver):_) -> ver
_ -> ""
}
hmakeProgram :: Program
hmakeProgram = (simpleProgram "hmake") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:ver:_) -> ver
_ -> ""
}
jhcProgram :: Program
jhcProgram = (simpleProgram "jhc") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:ver:_) -> ver
_ -> ""
}
hugsProgram :: Program
hugsProgram = simpleProgram "hugs"
ffihugsProgram :: Program
ffihugsProgram = simpleProgram "ffihugs"
happyProgram :: Program
happyProgram = (simpleProgram "happy") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:_:ver:_) -> ver
_ -> ""
}
alexProgram :: Program
alexProgram = (simpleProgram "alex") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver
_ -> ""
}
gccProgram :: Program
gccProgram = (simpleProgram "gcc") {
programFindVersion = findProgramVersion "-dumpversion" id
}
ranlibProgram :: Program
ranlibProgram = simpleProgram "ranlib"
arProgram :: Program
arProgram = simpleProgram "ar"
stripProgram :: Program
stripProgram = simpleProgram "strip"
hsc2hsProgram :: Program
hsc2hsProgram = (simpleProgram "hsc2hs") {
programFindVersion =
findProgramVersion "--version" $ \str ->
case words str of
(_:_:ver:_) -> ver
_ -> ""
}
c2hsProgram :: Program
c2hsProgram = (simpleProgram "c2hs") {
programFindVersion = findProgramVersion "--numeric-version" id
}
cpphsProgram :: Program
cpphsProgram = (simpleProgram "cpphs") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:ver:_) -> ver
_ -> ""
}
hscolourProgram :: Program
hscolourProgram = (simpleProgram "hscolour") {
programFindLocation = findProgramOnPath "HsColour",
programFindVersion = findProgramVersion "-version" $ \str ->
case words str of
(_:ver:_) -> ver
_ -> ""
}
haddockProgram :: Program
haddockProgram = (simpleProgram "haddock") {
programFindVersion = findProgramVersion "--version" $ \str ->
case words str of
(_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver
_ -> ""
}
greencardProgram :: Program
greencardProgram = simpleProgram "greencard"
ldProgram :: Program
ldProgram = simpleProgram "ld"
tarProgram :: Program
tarProgram = simpleProgram "tar"
cppProgram :: Program
cppProgram = simpleProgram "cpp"
pkgConfigProgram :: Program
pkgConfigProgram = (simpleProgram "pkg-config") {
programFindVersion = findProgramVersion "--version" id
}