module Distribution.Simple.Program.Db (
ProgramDb,
emptyProgramDb,
defaultProgramDb,
restoreProgramDb,
addKnownProgram,
addKnownPrograms,
lookupKnownProgram,
knownPrograms,
getProgramSearchPath,
setProgramSearchPath,
modifyProgramSearchPath,
userSpecifyPath,
userSpecifyPaths,
userMaybeSpecifyPath,
userSpecifyArgs,
userSpecifyArgss,
userSpecifiedArgs,
lookupProgram,
updateProgram,
configuredPrograms,
configureProgram,
configureAllKnownPrograms,
lookupProgramVersion,
reconfigurePrograms,
requireProgram,
requireProgramVersion,
) where
import Distribution.Simple.Program.Types
( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )
import Distribution.Simple.Program.Find
( ProgramSearchPath, defaultProgramSearchPath
, findProgramOnSearchPath, programSearchPathAsPATHVar )
import Distribution.Simple.Program.Builtin
( builtinPrograms )
import Distribution.Simple.Utils
( die, doesExecutableExist )
import Distribution.Version
( Version, VersionRange, isAnyVersion, withinRange )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Distribution.Compat.Binary (Binary(..))
#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif
import Data.List
( foldl' )
import Data.Maybe
( catMaybes )
import qualified Data.Map as Map
import Control.Monad
( join, foldM )
data ProgramDb = ProgramDb {
unconfiguredProgs :: UnconfiguredProgs,
progSearchPath :: ProgramSearchPath,
configuredProgs :: ConfiguredProgs
}
type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])
type UnconfiguredProgs = Map.Map String UnconfiguredProgram
type ConfiguredProgs = Map.Map String ConfiguredProgram
emptyProgramDb :: ProgramDb
emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty
defaultProgramDb :: ProgramDb
defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb
updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)
-> ProgramDb -> ProgramDb
updateUnconfiguredProgs update conf =
conf { unconfiguredProgs = update (unconfiguredProgs conf) }
updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)
-> ProgramDb -> ProgramDb
updateConfiguredProgs update conf =
conf { configuredProgs = update (configuredProgs conf) }
instance Show ProgramDb where
show = show . Map.toAscList . configuredProgs
instance Read ProgramDb where
readsPrec p s =
[ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)
| (s', r) <- readsPrec p s ]
instance Binary ProgramDb where
put = put . configuredProgs
get = do
progs <- get
return $! emptyProgramDb { configuredProgs = progs }
restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb
restoreProgramDb = addKnownPrograms
addKnownProgram :: Program -> ProgramDb -> ProgramDb
addKnownProgram prog = updateUnconfiguredProgs $
Map.insertWith combine (programName prog) (prog, Nothing, [])
where combine _ (_, path, args) = (prog, path, args)
addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb
addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs
lookupKnownProgram :: String -> ProgramDb -> Maybe Program
lookupKnownProgram name =
fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs
knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms conf =
[ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)
, let p' = Map.lookup (programName p) (configuredProgs conf) ]
getProgramSearchPath :: ProgramDb -> ProgramSearchPath
getProgramSearchPath = progSearchPath
setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
-> ProgramDb
-> ProgramDb
modifyProgramSearchPath f db =
setProgramSearchPath (f $ getProgramSearchPath db) db
userSpecifyPath :: String
-> FilePath
-> ProgramDb -> ProgramDb
userSpecifyPath name path = updateUnconfiguredProgs $
flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args)
userMaybeSpecifyPath :: String -> Maybe FilePath
-> ProgramDb -> ProgramDb
userMaybeSpecifyPath _ Nothing conf = conf
userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf
userSpecifyArgs :: String
-> [ProgArg]
-> ProgramDb
-> ProgramDb
userSpecifyArgs name args' =
updateUnconfiguredProgs
(flip Map.update name $
\(prog, path, args) -> Just (prog, path, args ++ args'))
. updateConfiguredProgs
(flip Map.update name $
\prog -> Just prog { programOverrideArgs = programOverrideArgs prog
++ args' })
userSpecifyPaths :: [(String, FilePath)]
-> ProgramDb
-> ProgramDb
userSpecifyPaths paths conf =
foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths
userSpecifyArgss :: [(String, [ProgArg])]
-> ProgramDb
-> ProgramDb
userSpecifyArgss argss conf =
foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss
userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath
userSpecifiedPath prog =
join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs
userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg]
userSpecifiedArgs prog =
maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs
lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram prog = Map.lookup (programName prog) . configuredProgs
updateProgram :: ConfiguredProgram -> ProgramDb
-> ProgramDb
updateProgram prog = updateConfiguredProgs $
Map.insert (programId prog) prog
configuredPrograms :: ProgramDb -> [ConfiguredProgram]
configuredPrograms = Map.elems . configuredProgs
configureProgram :: Verbosity
-> Program
-> ProgramDb
-> IO ProgramDb
configureProgram verbosity prog conf = do
let name = programName prog
maybeLocation <- case userSpecifiedPath prog conf of
Nothing -> programFindLocation prog verbosity (progSearchPath conf)
>>= return . fmap FoundOnSystem
Just path -> do
absolute <- doesExecutableExist path
if absolute
then return (Just (UserSpecified path))
else findProgramOnSearchPath verbosity (progSearchPath conf) path
>>= maybe (die notFound) (return . Just . UserSpecified)
where notFound = "Cannot find the program '" ++ name
++ "'. User-specified path '"
++ path ++ "' does not refer to an executable and "
++ "the program is not on the system path."
case maybeLocation of
Nothing -> return conf
Just location -> do
version <- programFindVersion prog verbosity (locationPath location)
newPath <- programSearchPathAsPATHVar (progSearchPath conf)
let configuredProg = ConfiguredProgram {
programId = name,
programVersion = version,
programDefaultArgs = [],
programOverrideArgs = userSpecifiedArgs prog conf,
programOverrideEnv = [("PATH", Just newPath)],
programProperties = Map.empty,
programLocation = location
}
configuredProg' <- programPostConf prog verbosity configuredProg
return (updateConfiguredProgs (Map.insert name configuredProg') conf)
configurePrograms :: Verbosity
-> [Program]
-> ProgramDb
-> IO ProgramDb
configurePrograms verbosity progs conf =
foldM (flip (configureProgram verbosity)) conf progs
configureAllKnownPrograms :: Verbosity
-> ProgramDb
-> IO ProgramDb
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])]
-> ProgramDb
-> IO ProgramDb
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 -> ProgramDb
-> IO (ConfiguredProgram, ProgramDb)
requireProgram verbosity prog 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 -> return (configuredProg, conf')
where notFound = "The program '" ++ programName prog
++ "' is required but it could not be found."
lookupProgramVersion
:: Verbosity -> Program -> VersionRange -> ProgramDb
-> IO (Either String (ConfiguredProgram, Version, ProgramDb))
lookupProgramVersion verbosity prog range programDb = do
programDb' <- case lookupProgram prog programDb of
Nothing -> configureProgram verbosity prog programDb
Just _ -> return programDb
case lookupProgram prog programDb' of
Nothing -> return $! Left notFound
Just configuredProg@ConfiguredProgram { programLocation = location } ->
case programVersion configuredProg of
Just version
| withinRange version range ->
return $! Right (configuredProg, version ,programDb')
| otherwise ->
return $! Left (badVersion version location)
Nothing ->
return $! Left (noVersion location)
where notFound = "The program '"
++ programName prog ++ "'" ++ versionRequirement
++ " is required but it could not be found."
badVersion v l = "The program '"
++ programName prog ++ "'" ++ versionRequirement
++ " is required but the version found at "
++ locationPath l ++ " is version " ++ display v
noVersion l = "The program '"
++ programName prog ++ "'" ++ versionRequirement
++ " is required but the version of "
++ locationPath l ++ " could not be determined."
versionRequirement
| isAnyVersion range = ""
| otherwise = " version " ++ display range
requireProgramVersion :: Verbosity -> Program -> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion verbosity prog range programDb =
join $ either die return <$>
lookupProgramVersion verbosity prog range programDb