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,
unconfigureProgram,
lookupProgramVersion,
reconfigurePrograms,
requireProgram,
requireProgramVersion,
needProgram,
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Pretty
import Distribution.Simple.Program.Builtin
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Utils.Structured (Structure (..), Structured (..))
import Distribution.Verbosity
import Distribution.Version
import Data.Tuple (swap)
import qualified Data.Map as Map
data ProgramDb = ProgramDb {
unconfiguredProgs :: UnconfiguredProgs,
progSearchPath :: ProgramSearchPath,
configuredProgs :: ConfiguredProgs
}
deriving (Typeable)
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 progdb =
progdb { unconfiguredProgs = update (unconfiguredProgs progdb) }
updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)
-> ProgramDb -> ProgramDb
updateConfiguredProgs update progdb =
progdb { configuredProgs = update (configuredProgs progdb) }
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 db = do
put (progSearchPath db)
put (configuredProgs db)
get = do
searchpath <- get
progs <- get
return $! emptyProgramDb {
progSearchPath = searchpath,
configuredProgs = progs
}
instance Structured ProgramDb where
structure p = Nominal (typeRep p) 0 "ProgramDb"
[ structure (Proxy :: Proxy ProgramSearchPath)
, structure (Proxy :: Proxy ConfiguredProgs)
]
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 progdb = foldl' (flip addKnownProgram) progdb progs
lookupKnownProgram :: String -> ProgramDb -> Maybe Program
lookupKnownProgram name =
fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs
knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms progdb =
[ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb)
, let p' = Map.lookup (programName p) (configuredProgs progdb) ]
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 progdb = progdb
userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb
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 progdb =
foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths
userSpecifyArgss :: [(String, [ProgArg])]
-> ProgramDb
-> ProgramDb
userSpecifyArgss argss progdb =
foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb 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 progdb = do
let name = programName prog
maybeLocation <- case userSpecifiedPath prog progdb of
Nothing ->
programFindLocation prog verbosity (progSearchPath progdb)
>>= return . fmap (swap . fmap FoundOnSystem . swap)
Just path -> do
absolute <- doesExecutableExist path
if absolute
then return (Just (UserSpecified path, []))
else findProgramOnSearchPath verbosity (progSearchPath progdb) path
>>= maybe (die' verbosity notFound)
(return . Just . swap . fmap UserSpecified . swap)
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 progdb
Just (location, triedLocations) -> do
version <- programFindVersion prog verbosity (locationPath location)
newPath <- programSearchPathAsPATHVar (progSearchPath progdb)
let configuredProg = ConfiguredProgram {
programId = name,
programVersion = version,
programDefaultArgs = [],
programOverrideArgs = userSpecifiedArgs prog progdb,
programOverrideEnv = [("PATH", Just newPath)],
programProperties = Map.empty,
programLocation = location,
programMonitorFiles = triedLocations
}
configuredProg' <- programPostConf prog verbosity configuredProg
return (updateConfiguredProgs (Map.insert name configuredProg') progdb)
configurePrograms :: Verbosity
-> [Program]
-> ProgramDb
-> IO ProgramDb
configurePrograms verbosity progs progdb =
foldM (flip (configureProgram verbosity)) progdb progs
unconfigureProgram :: String -> ProgramDb -> ProgramDb
unconfigureProgram progname =
updateConfiguredProgs $ Map.delete progname
configureAllKnownPrograms :: Verbosity
-> ProgramDb
-> IO ProgramDb
configureAllKnownPrograms verbosity progdb =
configurePrograms verbosity
[ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb
where
notYetConfigured = unconfiguredProgs progdb
`Map.difference` configuredProgs progdb
reconfigurePrograms :: Verbosity
-> [(String, FilePath)]
-> [(String, [ProgArg])]
-> ProgramDb
-> IO ProgramDb
reconfigurePrograms verbosity paths argss progdb = do
configurePrograms verbosity progs
. userSpecifyPaths paths
. userSpecifyArgss argss
$ progdb
where
progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ]
requireProgram :: Verbosity -> Program -> ProgramDb
-> IO (ConfiguredProgram, ProgramDb)
requireProgram verbosity prog progdb = do
mres <- needProgram verbosity prog progdb
case mres of
Nothing -> die' verbosity notFound
Just res -> return res
where
notFound = "The program '" ++ programName prog ++ "' is required but it could not be found."
needProgram :: Verbosity -> Program -> ProgramDb
-> IO (Maybe (ConfiguredProgram, ProgramDb))
needProgram verbosity prog progdb = do
progdb' <- case lookupProgram prog progdb of
Nothing -> configureProgram verbosity prog progdb
Just _ -> return progdb
case lookupProgram prog progdb' of
Nothing -> return Nothing
Just configuredProg -> return (Just (configuredProg, progdb'))
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 (unknownVersion 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 " ++ prettyShow v
unknownVersion l = "The program '"
++ programName prog ++ "'" ++ versionRequirement
++ " is required but the version of "
++ locationPath l ++ " could not be determined."
versionRequirement
| isAnyVersion range = ""
| otherwise = " version " ++ prettyShow range
requireProgramVersion :: Verbosity -> Program -> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion verbosity prog range programDb =
join $ either (die' verbosity) return `fmap`
lookupProgramVersion verbosity prog range programDb