module Distribution.PackageDescription.Configuration (
finalizePD,
finalizePackageDescription,
flattenPackageDescription,
parseCondition,
freeVars,
extractCondition,
extractConditions,
addBuildableCondition,
mapCondTree,
mapTreeData,
mapTreeConds,
mapTreeConstrs,
transformAllBuildInfos,
transformAllBuildDepends,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
import Distribution.Version
import Distribution.Compiler
import Distribution.System
import Distribution.Simple.Utils
import Distribution.Text
import Distribution.Compat.ReadP as ReadP hiding ( char )
import qualified Distribution.Compat.ReadP as ReadP ( char )
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.Component
import Distribution.Types.Dependency
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.Types.Condition
import Distribution.Types.DependencyMap
import qualified Data.Map as Map
import Data.Tree ( Tree(Node) )
simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar
-> (Condition FlagName, [FlagName])
simplifyWithSysParams os arch cinfo cond = (cond', flags)
where
(cond', flags) = simplifyCondition cond interp
interp (OS os') = Right $ os' == os
interp (Arch arch') = Right $ arch' == arch
interp (Impl comp vr)
| matchImpl (compilerInfoId cinfo) = Right True
| otherwise = case compilerInfoCompat cinfo of
Nothing -> Right False
Just compat -> Right (any matchImpl compat)
where
matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
interp (Flag f) = Left f
parseCondition :: ReadP r (Condition ConfVar)
parseCondition = condOr
where
condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr
condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd
cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond
+++ archCond +++ flagCond +++ implCond )
inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
notCond = ReadP.char '!' >> sp >> cond >>= return . CNot
osCond = string "os" >> sp >> inparens osIdent >>= return . Var
archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var
implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
boolLiteral = fmap Lit parse
archIdent = fmap Arch parse
osIdent = fmap OS parse
flagIdent = fmap (Flag . mkFlagName . lowercase) (munch1 isIdentChar)
isIdentChar c = isAlphaNum c || c == '_' || c == '-'
oper s = sp >> string s >> sp
sp = skipSpaces
implIdent = do i <- parse
vr <- sp >> option anyVersion parse
return $ Impl i vr
data DepTestRslt d = DepOk | MissingDeps d
instance Semigroup d => Monoid (DepTestRslt d) where
mempty = DepOk
mappend = (<>)
instance Semigroup d => Semigroup (DepTestRslt d) where
DepOk <> x = x
x <> DepOk = x
(MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
resolveWithFlags ::
[(FlagName,[Bool])]
-> ComponentRequestedSpec
-> OS
-> Arch
-> CompilerInfo
-> [Dependency]
-> [CondTree ConfVar [Dependency] PDTagged]
-> ([Dependency] -> DepTestRslt [Dependency])
-> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
either (Left . fromDepMapUnion) Right $ explore (build [] dom)
where
extraConstrs = toDepMap constrs
simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
simplifiedTrees = map ( mapTreeConstrs toDepMap
. addBuildableConditionPDTagged
. mapTreeConds (fst . simplifyWithSysParams os arch impl))
trees
explore :: Tree FlagAssignment
-> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
explore (Node flags ts) =
let targetSet = TargetSet $ flip map simplifiedTrees $
first (`constrainBy` extraConstrs) .
simplifyCondTree (env flags)
deps = overallDependencies enabled targetSet
in case checkDeps (fromDepMap deps) of
DepOk | null ts -> Right (targetSet, flags)
| otherwise -> tryAll $ map explore ts
MissingDeps mds -> Left (toDepMapUnion mds)
build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment
build assigned [] = Node assigned []
build assigned ((fn, vals) : unassigned) =
Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals
tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
tryAll = foldr mp mz
mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
mp m@(Right _) _ = m
mp _ m@(Right _) = m
mp (Left xs) (Left ys) =
let union = Map.foldrWithKey (Map.insertWith' combine)
(unDepMapUnion xs) (unDepMapUnion ys)
combine x y = simplifyVersionRange $ unionVersionRanges x y
in union `seq` Left (DepMapUnion union)
mz :: Either DepMapUnion a
mz = Left (DepMapUnion Map.empty)
env :: FlagAssignment -> FlagName -> Either FlagName Bool
env flags flag = (maybe (Left flag) Right . lookup flag) flags
addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo)
-> CondTree v c a
-> CondTree v c a
addBuildableCondition getInfo t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
Lit False -> CondNode mempty mempty []
c -> CondNode mempty mempty [condIfThen c t]
addBuildableConditionPDTagged :: (Eq v, Monoid c) =>
CondTree v c PDTagged
-> CondTree v c PDTagged
addBuildableConditionPDTagged t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
Lit False -> deleteConstraints t
c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
where
deleteConstraints = mapTreeConstrs (const mempty)
getInfo :: PDTagged -> BuildInfo
getInfo (Lib l) = libBuildInfo l
getInfo (SubComp _ c) = componentBuildInfo c
getInfo PDNull = mempty
extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription
-> [Condition ConfVar]
extractConditions f gpkg =
concat [
extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg)
, extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg
, extractCondition (f . buildInfo) . snd <$> condExecutables gpkg
, extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg
, extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
]
newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange }
toDepMapUnion :: [Dependency] -> DepMapUnion
toDepMapUnion ds =
DepMapUnion $ Map.fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ]
fromDepMapUnion :: DepMapUnion -> [Dependency]
fromDepMapUnion m = [ Dependency p vr | (p,vr) <- Map.toList (unDepMapUnion m) ]
freeVars :: CondTree ConfVar c a -> [FlagName]
freeVars t = [ f | Flag f <- freeVars' t ]
where
freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
condfv c = case c of
Var v -> [v]
Lit _ -> []
CNot c' -> condfv c'
COr c1 c2 -> condfv c1 ++ condfv c2
CAnd c1 c2 -> condfv c1 ++ condfv c2
newtype TargetSet a = TargetSet [(DependencyMap, a)]
overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap
overallDependencies enabled (TargetSet targets) = mconcat depss
where
(depss, _) = unzip $ filter (removeDisabledSections . snd) targets
removeDisabledSections :: PDTagged -> Bool
removeDisabledSections (Lib _) = componentNameRequested enabled CLibName
removeDisabledSections (SubComp t c)
= componentNameRequested enabled
$ case c of
CLib _ -> CSubLibName t
CFLib _ -> CFLibName t
CExe _ -> CExeName t
CTest _ -> CTestName t
CBench _ -> CBenchName t
removeDisabledSections PDNull = True
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
where
untag (_, Lib _) (Just _, _) = userBug "Only one library expected"
untag (_, Lib l) (Nothing, comps) = (Just l, comps)
untag (_, SubComp n c) (mb_lib, comps)
| any ((== n) . fst) comps =
userBug $ "There exist several components with the same name: '" ++ unUnqualComponentName n ++ "'"
| otherwise = (mb_lib, (n, c) : comps)
untag (_, PDNull) x = x
data PDTagged = Lib Library
| SubComp UnqualComponentName Component
| PDNull
deriving Show
instance Monoid PDTagged where
mempty = PDNull
mappend = (<>)
instance Semigroup PDTagged where
PDNull <> x = x
x <> PDNull = x
Lib l <> Lib l' = Lib (l <> l')
SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
_ <> _ = cabalBug "Cannot combine incompatible tags"
finalizePD ::
FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [Dependency]
-> GenericPackageDescription
-> Either [Dependency]
(PackageDescription, FlagAssignment)
finalizePD userflags enabled satisfyDep
(Platform arch os) impl constraints
(GenericPackageDescription pkg flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do
(targetSet, flagVals) <-
resolveWithFlags flagChoices enabled os arch impl constraints condTrees check
let
(mb_lib, comps) = flattenTaggedTargets targetSet
mb_lib' = fmap libFillInDefaults mb_lib
comps' = flip map comps $ \(n,c) -> foldComponent
(\l -> CLib (libFillInDefaults l) { libName = Just n
, libExposed = False })
(\l -> CFLib (flibFillInDefaults l) { foreignLibName = n })
(\e -> CExe (exeFillInDefaults e) { exeName = n })
(\t -> CTest (testFillInDefaults t) { testName = n })
(\b -> CBench (benchFillInDefaults b) { benchmarkName = n })
c
(sub_libs', flibs', exes', tests', bms') = partitionComponents comps'
return ( pkg { library = mb_lib'
, subLibraries = sub_libs'
, foreignLibs = flibs'
, executables = exes'
, testSuites = tests'
, benchmarks = bms'
, buildDepends = fromDepMap (overallDependencies enabled targetSet)
}
, flagVals )
where
condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0)
++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0
++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0
++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0
++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0
++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0
flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
d2c manual n b = case lookup n userflags of
Just val -> [val]
Nothing
| manual -> [b]
| otherwise -> [b, not b]
check ds = let missingDeps = filter (not . satisfyDep) ds
in if null missingDeps
then DepOk
else MissingDeps missingDeps
finalizePackageDescription ::
FlagAssignment
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [Dependency]
-> GenericPackageDescription
-> Either [Dependency]
(PackageDescription, FlagAssignment)
finalizePackageDescription flags = finalizePD flags defaultComponentRequestedSpec
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
flattenPackageDescription
(GenericPackageDescription pkg _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =
pkg { library = mlib
, subLibraries = reverse sub_libs
, foreignLibs = reverse flibs
, executables = reverse exes
, testSuites = reverse tests
, benchmarks = reverse bms
, buildDepends = ldeps
++ reverse sub_ldeps
++ reverse pldeps
++ reverse edeps
++ reverse tdeps
++ reverse bdeps
}
where
(mlib, ldeps) = case mlib0 of
Just lib -> let (l,ds) = ignoreConditions lib in
(Just ((libFillInDefaults l) { libName = Nothing }), ds)
Nothing -> (Nothing, [])
(sub_libs, sub_ldeps) = foldr flattenLib ([],[]) sub_libs0
(flibs, pldeps) = foldr flattenFLib ([],[]) flibs0
(exes, edeps) = foldr flattenExe ([],[]) exes0
(tests, tdeps) = foldr flattenTst ([],[]) tests0
(bms, bdeps) = foldr flattenBm ([],[]) bms0
flattenLib (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (libFillInDefaults $ e { libName = Just n, libExposed = False }) : es, ds' ++ ds )
flattenFLib (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (flibFillInDefaults $ e { foreignLibName = n }) : es, ds' ++ ds )
flattenExe (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
flattenTst (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )
flattenBm (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )
libFillInDefaults :: Library -> Library
libFillInDefaults lib@(Library { libBuildInfo = bi }) =
lib { libBuildInfo = biFillInDefaults bi }
flibFillInDefaults :: ForeignLib -> ForeignLib
flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) =
flib { foreignLibBuildInfo = biFillInDefaults bi }
exeFillInDefaults :: Executable -> Executable
exeFillInDefaults exe@(Executable { buildInfo = bi }) =
exe { buildInfo = biFillInDefaults bi }
testFillInDefaults :: TestSuite -> TestSuite
testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
tst { testBuildInfo = biFillInDefaults bi }
benchFillInDefaults :: Benchmark -> Benchmark
benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
bm { benchmarkBuildInfo = biFillInDefaults bi }
biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
if null (hsSourceDirs bi)
then bi { hsSourceDirs = [currentDir] }
else bi
transformAllBuildInfos :: (BuildInfo -> BuildInfo)
-> (SetupBuildInfo -> SetupBuildInfo)
-> GenericPackageDescription
-> GenericPackageDescription
transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'
where
onLibrary lib = lib { libBuildInfo = onBuildInfo $ libBuildInfo lib }
onExecutable exe = exe { buildInfo = onBuildInfo $ buildInfo exe }
onTestSuite tst = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }
onBenchmark bmk = bmk { benchmarkBuildInfo =
onBuildInfo $ benchmarkBuildInfo bmk }
pd = packageDescription gpd
pd' = pd {
library = fmap onLibrary (library pd),
subLibraries = map onLibrary (subLibraries pd),
executables = map onExecutable (executables pd),
testSuites = map onTestSuite (testSuites pd),
benchmarks = map onBenchmark (benchmarks pd),
setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)
}
gpd' = transformAllCondTrees onLibrary onExecutable
onTestSuite onBenchmark id
$ gpd { packageDescription = pd' }
transformAllBuildDepends :: (Dependency -> Dependency)
-> GenericPackageDescription
-> GenericPackageDescription
transformAllBuildDepends f gpd = gpd'
where
onBI bi = bi { targetBuildDepends = map f $ targetBuildDepends bi }
onSBI stp = stp { setupDepends = map f $ setupDepends stp }
onPD pd = pd { buildDepends = map f $ buildDepends pd }
pd' = onPD $ packageDescription gpd
gpd' = transformAllCondTrees id id id id (map f)
. transformAllBuildInfos onBI onSBI
$ gpd { packageDescription = pd' }
transformAllCondTrees :: (Library -> Library)
-> (Executable -> Executable)
-> (TestSuite -> TestSuite)
-> (Benchmark -> Benchmark)
-> ([Dependency] -> [Dependency])
-> GenericPackageDescription -> GenericPackageDescription
transformAllCondTrees onLibrary onExecutable
onTestSuite onBenchmark onDepends gpd = gpd'
where
gpd' = gpd {
condLibrary = condLib',
condSubLibraries = condSubLibs',
condExecutables = condExes',
condTestSuites = condTests',
condBenchmarks = condBenchs'
}
condLib = condLibrary gpd
condSubLibs = condSubLibraries gpd
condExes = condExecutables gpd
condTests = condTestSuites gpd
condBenchs = condBenchmarks gpd
condLib' = fmap (onCondTree onLibrary) condLib
condSubLibs' = map (mapSnd $ onCondTree onLibrary) condSubLibs
condExes' = map (mapSnd $ onCondTree onExecutable) condExes
condTests' = map (mapSnd $ onCondTree onTestSuite) condTests
condBenchs' = map (mapSnd $ onCondTree onBenchmark) condBenchs
mapSnd :: (a -> b) -> (c,a) -> (c,b)
mapSnd = fmap
onCondTree :: (a -> b) -> CondTree v [Dependency] a
-> CondTree v [Dependency] b
onCondTree g = mapCondTree g onDepends id