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 qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
import qualified Distribution.Types.SetupBuildInfo.Lens as L
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.Lens
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.Strict as Map.Strict
import qualified Data.Map.Lazy 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 mempty 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 (insertFlagAssignment 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.Strict.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 . lookupFlagAssignment 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 (depMap, pdTagged) accum = case (pdTagged, accum) of
(Lib _, (Just _, _)) -> userBug "Only one library expected"
(Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps)
(SubComp n c, (mb_lib, comps))
| any ((== n) . fst) comps ->
userBug $ "There exist several components with the same name: '" ++ display n ++ "'"
| otherwise -> (mb_lib, (n, redoBD c) : comps)
(PDNull, x) -> x
where
redoBD :: L.HasBuildInfo a => a -> a
redoBD = set L.targetBuildDepends $ fromDepMap depMap
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'
}
, 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 lookupFlagAssignment 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
}
where
mlib = f <$> mlib0
where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = Nothing }
sub_libs = flattenLib <$> sub_libs0
flibs = flattenFLib <$> flibs0
exes = flattenExe <$> exes0
tests = flattenTst <$> tests0
bms = flattenBm <$> bms0
flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t)
{ libName = Just n, libExposed = False }
flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t)
{ foreignLibName = n }
flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t)
{ exeName = n }
flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t)
{ testName = n }
flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t)
{ benchmarkName = n }
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 =
over L.traverseBuildInfos onBuildInfo
. over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo
transformAllBuildDepends :: (Dependency -> Dependency)
-> GenericPackageDescription
-> GenericPackageDescription
transformAllBuildDepends f =
over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
. over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
. over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)