module Distribution.PackageDescription.Configuration (
finalizePD,
flattenPackageDescription,
parseCondition,
freeVars,
extractCondition,
extractConditions,
addBuildableCondition,
mapCondTree,
mapTreeData,
mapTreeConds,
mapTreeConstrs,
transformAllBuildInfos,
transformAllBuildDepends,
transformAllBuildDependsN,
) where
import Distribution.Compat.Prelude
import 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.Compat.CharParsing hiding (char)
import qualified Distribution.Compat.CharParsing as P
import Distribution.Compat.Lens
import Distribution.Compiler
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.Component
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.DependencyMap
import Distribution.Types.PackageVersionConstraint
import Distribution.Version
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 (PackageFlag f) = Left f
parseCondition :: CabalParsing m => m (Condition ConfVar)
parseCondition = condOr
where
condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd
cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond
<|> archCond <|> flagCond <|> implCond )
inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp)
notCond = P.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 parsec
archIdent = fmap Arch parsec
osIdent = fmap OS parsec
flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar)
isIdentChar c = isAlphaNum c || c == '_' || c == '-'
oper s = sp >> string s >> sp
sp = spaces
implIdent = do i <- parsec
vr <- sp >> option anyVersion parsec
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
-> [PackageVersionConstraint]
-> [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
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` constrs) .
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) = Left (xs <> ys)
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, NonEmptySet LibraryName) }
instance Semigroup DepMapUnion where
DepMapUnion x <> DepMapUnion y = DepMapUnion $
Map.unionWith unionVersionRanges' x y
unionVersionRanges'
:: (VersionRange, NonEmptySet LibraryName)
-> (VersionRange, NonEmptySet LibraryName)
-> (VersionRange, NonEmptySet LibraryName)
unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
toDepMapUnion :: [Dependency] -> DepMapUnion
toDepMapUnion ds =
DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ]
fromDepMapUnion :: DepMapUnion -> [Dependency]
fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ]
freeVars :: CondTree ConfVar c a -> [FlagName]
freeVars t = [ f | PackageFlag 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 LMainLibName)
removeDisabledSections (SubComp t c)
= componentNameRequested enabled
$ case c of
CLib _ -> CLibName (LSubLibName 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: '" ++ prettyShow 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
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency]
(PackageDescription, FlagAssignment)
finalizePD userflags enabled satisfyDep
(Platform arch os) impl constraints
(GenericPackageDescription pkg _ver 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 = LSubLibName 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 (\(MkPackageFlag 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
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 = LMainLibName }
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 = LSubLibName 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)
transformAllBuildDependsN :: ([Dependency] -> [Dependency])
-> GenericPackageDescription
-> GenericPackageDescription
transformAllBuildDependsN f =
over (L.traverseBuildInfos . L.targetBuildDepends) f
. over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f
. over (\f' -> L.allCondTrees $ traverseCondTreeC f') f