1-- -fno-warn-deprecations for use of Map.foldWithKey 2{-# OPTIONS_GHC -fno-warn-deprecations #-} 3----------------------------------------------------------------------------- 4-- | 5-- Module : Distribution.PackageDescription.Configuration 6-- Copyright : Thomas Schilling, 2007 7-- License : BSD3 8-- 9-- Maintainer : cabal-devel@haskell.org 10-- Portability : portable 11-- 12-- This is about the cabal configurations feature. It exports 13-- 'finalizePD' and 'flattenPackageDescription' which are 14-- functions for converting 'GenericPackageDescription's down to 15-- 'PackageDescription's. It has code for working with the tree of conditions 16-- and resolving or flattening conditions. 17 18module Distribution.PackageDescription.Configuration ( 19 finalizePD, 20 flattenPackageDescription, 21 22 -- Utils 23 parseCondition, 24 freeVars, 25 extractCondition, 26 extractConditions, 27 addBuildableCondition, 28 mapCondTree, 29 mapTreeData, 30 mapTreeConds, 31 mapTreeConstrs, 32 transformAllBuildInfos, 33 transformAllBuildDepends, 34 transformAllBuildDependsN, 35 ) where 36 37import Distribution.Compat.Prelude 38import Prelude () 39 40-- lens 41import qualified Distribution.Types.BuildInfo.Lens as L 42import qualified Distribution.Types.GenericPackageDescription.Lens as L 43import qualified Distribution.Types.PackageDescription.Lens as L 44import qualified Distribution.Types.SetupBuildInfo.Lens as L 45 46import Distribution.Compat.CharParsing hiding (char) 47import qualified Distribution.Compat.CharParsing as P 48import Distribution.Compat.Lens 49import Distribution.Compiler 50import Distribution.PackageDescription 51import Distribution.PackageDescription.Utils 52import Distribution.Parsec 53import Distribution.Pretty 54import Distribution.Simple.Utils 55import Distribution.System 56import Distribution.Types.Component 57import Distribution.Utils.Path 58import Distribution.Types.ComponentRequestedSpec 59import Distribution.Types.DependencyMap 60import Distribution.Types.PackageVersionConstraint 61import Distribution.Version 62 63import qualified Data.Map.Lazy as Map 64import Data.Tree (Tree (Node)) 65 66------------------------------------------------------------------------------ 67 68-- | Simplify a configuration condition using the OS and arch names. Returns 69-- the names of all the flags occurring in the condition. 70simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar 71 -> (Condition FlagName, [FlagName]) 72simplifyWithSysParams os arch cinfo cond = (cond', flags) 73 where 74 (cond', flags) = simplifyCondition cond interp 75 interp (OS os') = Right $ os' == os 76 interp (Arch arch') = Right $ arch' == arch 77 interp (Impl comp vr) 78 | matchImpl (compilerInfoId cinfo) = Right True 79 | otherwise = case compilerInfoCompat cinfo of 80 -- fixme: treat Nothing as unknown, rather than empty list once we 81 -- support partial resolution of system parameters 82 Nothing -> Right False 83 Just compat -> Right (any matchImpl compat) 84 where 85 matchImpl (CompilerId c v) = comp == c && v `withinRange` vr 86 interp (PackageFlag f) = Left f 87 88-- TODO: Add instances and check 89-- 90-- prop_sC_idempotent cond a o = cond' == cond'' 91-- where 92-- cond' = simplifyCondition cond a o 93-- cond'' = simplifyCondition cond' a o 94-- 95-- prop_sC_noLits cond a o = isLit res || not (hasLits res) 96-- where 97-- res = simplifyCondition cond a o 98-- hasLits (Lit _) = True 99-- hasLits (CNot c) = hasLits c 100-- hasLits (COr l r) = hasLits l || hasLits r 101-- hasLits (CAnd l r) = hasLits l || hasLits r 102-- hasLits _ = False 103-- 104 105-- | Parse a configuration condition from a string. 106parseCondition :: CabalParsing m => m (Condition ConfVar) 107parseCondition = condOr 108 where 109 condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr 110 condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd 111 -- TODO: try? 112 cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond 113 <|> archCond <|> flagCond <|> implCond ) 114 inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) 115 notCond = P.char '!' >> sp >> cond >>= return . CNot 116 osCond = string "os" >> sp >> inparens osIdent >>= return . Var 117 archCond = string "arch" >> sp >> inparens archIdent >>= return . Var 118 flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var 119 implCond = string "impl" >> sp >> inparens implIdent >>= return . Var 120 boolLiteral = fmap Lit parsec 121 archIdent = fmap Arch parsec 122 osIdent = fmap OS parsec 123 flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) 124 isIdentChar c = isAlphaNum c || c == '_' || c == '-' 125 oper s = sp >> string s >> sp 126 sp = spaces 127 implIdent = do i <- parsec 128 vr <- sp >> option anyVersion parsec 129 return $ Impl i vr 130 131------------------------------------------------------------------------------ 132 133-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for 134-- clarity. 135data DepTestRslt d = DepOk | MissingDeps d 136 137instance Semigroup d => Monoid (DepTestRslt d) where 138 mempty = DepOk 139 mappend = (<>) 140 141instance Semigroup d => Semigroup (DepTestRslt d) where 142 DepOk <> x = x 143 x <> DepOk = x 144 (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') 145 146 147-- | Try to find a flag assignment that satisfies the constraints of all trees. 148-- 149-- Returns either the missing dependencies, or a tuple containing the 150-- resulting data, the associated dependencies, and the chosen flag 151-- assignments. 152-- 153-- In case of failure, the union of the dependencies that led to backtracking 154-- on all branches is returned. 155-- [TODO: Could also be specified with a function argument.] 156-- 157-- TODO: The current algorithm is rather naive. A better approach would be to: 158-- 159-- * Rule out possible paths, by taking a look at the associated dependencies. 160-- 161-- * Infer the required values for the conditions of these paths, and 162-- calculate the required domains for the variables used in these 163-- conditions. Then picking a flag assignment would be linear (I guess). 164-- 165-- This would require some sort of SAT solving, though, thus it's not 166-- implemented unless we really need it. 167-- 168resolveWithFlags :: 169 [(FlagName,[Bool])] 170 -- ^ Domain for each flag name, will be tested in order. 171 -> ComponentRequestedSpec 172 -> OS -- ^ OS as returned by Distribution.System.buildOS 173 -> Arch -- ^ Arch as returned by Distribution.System.buildArch 174 -> CompilerInfo -- ^ Compiler information 175 -> [PackageVersionConstraint] -- ^ Additional constraints 176 -> [CondTree ConfVar [Dependency] PDTagged] 177 -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. 178 -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) 179 -- ^ Either the missing dependencies (error case), or a pair of 180 -- (set of build targets with dependencies, chosen flag assignments) 181resolveWithFlags dom enabled os arch impl constrs trees checkDeps = 182 either (Left . fromDepMapUnion) Right $ explore (build mempty dom) 183 where 184 -- simplify trees by (partially) evaluating all conditions and converting 185 -- dependencies to dependency maps. 186 simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] 187 simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps 188 . addBuildableConditionPDTagged 189 . mapTreeConds (fst . simplifyWithSysParams os arch impl)) 190 trees 191 192 -- @explore@ searches a tree of assignments, backtracking whenever a flag 193 -- introduces a dependency that cannot be satisfied. If there is no 194 -- solution, @explore@ returns the union of all dependencies that caused 195 -- it to backtrack. Since the tree is constructed lazily, we avoid some 196 -- computation overhead in the successful case. 197 explore :: Tree FlagAssignment 198 -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) 199 explore (Node flags ts) = 200 let targetSet = TargetSet $ flip map simplifiedTrees $ 201 -- apply additional constraints to all dependencies 202 first (`constrainBy` constrs) . 203 simplifyCondTree (env flags) 204 deps = overallDependencies enabled targetSet 205 in case checkDeps (fromDepMap deps) of 206 DepOk | null ts -> Right (targetSet, flags) 207 | otherwise -> tryAll $ map explore ts 208 MissingDeps mds -> Left (toDepMapUnion mds) 209 210 -- Builds a tree of all possible flag assignments. Internal nodes 211 -- have only partial assignments. 212 build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment 213 build assigned [] = Node assigned [] 214 build assigned ((fn, vals) : unassigned) = 215 Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals 216 217 tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a 218 tryAll = foldr mp mz 219 220 -- special version of `mplus' for our local purposes 221 mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a 222 mp m@(Right _) _ = m 223 mp _ m@(Right _) = m 224 mp (Left xs) (Left ys) = Left (xs <> ys) 225 226 -- `mzero' 227 mz :: Either DepMapUnion a 228 mz = Left (DepMapUnion Map.empty) 229 230 env :: FlagAssignment -> FlagName -> Either FlagName Bool 231 env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags 232 233-- | Transforms a 'CondTree' by putting the input under the "then" branch of a 234-- conditional that is True when Buildable is True. If 'addBuildableCondition' 235-- can determine that Buildable is always True, it returns the input unchanged. 236-- If Buildable is always False, it returns the empty 'CondTree'. 237addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) 238 -> CondTree v c a 239 -> CondTree v c a 240addBuildableCondition getInfo t = 241 case extractCondition (buildable . getInfo) t of 242 Lit True -> t 243 Lit False -> CondNode mempty mempty [] 244 c -> CondNode mempty mempty [condIfThen c t] 245 246-- | This is a special version of 'addBuildableCondition' for the 'PDTagged' 247-- type. 248-- 249-- It is not simply a specialisation. It is more complicated than it 250-- ought to be because of the way the 'PDTagged' monoid instance works. The 251-- @mempty = 'PDNull'@ forgets the component type, which has the effect of 252-- completely deleting components that are not buildable. 253-- 254-- See <https://github.com/haskell/cabal/pull/4094> for more details. 255-- 256addBuildableConditionPDTagged :: (Eq v, Monoid c) => 257 CondTree v c PDTagged 258 -> CondTree v c PDTagged 259addBuildableConditionPDTagged t = 260 case extractCondition (buildable . getInfo) t of 261 Lit True -> t 262 Lit False -> deleteConstraints t 263 c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] 264 where 265 deleteConstraints = mapTreeConstrs (const mempty) 266 267 getInfo :: PDTagged -> BuildInfo 268 getInfo (Lib l) = libBuildInfo l 269 getInfo (SubComp _ c) = componentBuildInfo c 270 getInfo PDNull = mempty 271 272 273-- Note: extracting buildable conditions. 274-- -------------------------------------- 275-- 276-- If the conditions in a cond tree lead to Buildable being set to False, then 277-- none of the dependencies for this cond tree should actually be taken into 278-- account. On the other hand, some of the flags may only be decided in the 279-- solver, so we cannot necessarily make the decision whether a component is 280-- Buildable or not prior to solving. 281-- 282-- What we are doing here is to partially evaluate a condition tree in order to 283-- extract the condition under which Buildable is True. The predicate determines 284-- whether data under a 'CondTree' is buildable. 285 286-- | Extract conditions matched by the given predicate from all cond trees in a 287-- 'GenericPackageDescription'. 288extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription 289 -> [Condition ConfVar] 290extractConditions f gpkg = 291 concat [ 292 extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) 293 , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg 294 , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg 295 , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg 296 , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg 297 ] 298 299 300-- | A map of package constraints that combines version ranges using 'unionVersionRanges'. 301newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } 302 303instance Semigroup DepMapUnion where 304 DepMapUnion x <> DepMapUnion y = DepMapUnion $ 305 Map.unionWith unionVersionRanges' x y 306 307unionVersionRanges' 308 :: (VersionRange, NonEmptySet LibraryName) 309 -> (VersionRange, NonEmptySet LibraryName) 310 -> (VersionRange, NonEmptySet LibraryName) 311unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') 312 313toDepMapUnion :: [Dependency] -> DepMapUnion 314toDepMapUnion ds = 315 DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] 316 317 318fromDepMapUnion :: DepMapUnion -> [Dependency] 319fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] 320 321freeVars :: CondTree ConfVar c a -> [FlagName] 322freeVars t = [ f | PackageFlag f <- freeVars' t ] 323 where 324 freeVars' (CondNode _ _ ifs) = concatMap compfv ifs 325 compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct 326 condfv c = case c of 327 Var v -> [v] 328 Lit _ -> [] 329 CNot c' -> condfv c' 330 COr c1 c2 -> condfv c1 ++ condfv c2 331 CAnd c1 c2 -> condfv c1 ++ condfv c2 332 333 334------------------------------------------------------------------------------ 335 336-- | A set of targets with their package dependencies 337newtype TargetSet a = TargetSet [(DependencyMap, a)] 338 339-- | Combine the target-specific dependencies in a TargetSet to give the 340-- dependencies for the package as a whole. 341overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap 342overallDependencies enabled (TargetSet targets) = mconcat depss 343 where 344 (depss, _) = unzip $ filter (removeDisabledSections . snd) targets 345 removeDisabledSections :: PDTagged -> Bool 346 -- UGH. The embedded componentName in the 'Component's here is 347 -- BLANK. I don't know whose fault this is but I'll use the tag 348 -- instead. -- ezyang 349 removeDisabledSections (Lib _) = componentNameRequested 350 enabled 351 (CLibName LMainLibName) 352 removeDisabledSections (SubComp t c) 353 -- Do NOT use componentName 354 = componentNameRequested enabled 355 $ case c of 356 CLib _ -> CLibName (LSubLibName t) 357 CFLib _ -> CFLibName t 358 CExe _ -> CExeName t 359 CTest _ -> CTestName t 360 CBench _ -> CBenchName t 361 removeDisabledSections PDNull = True 362 363-- | Collect up the targets in a TargetSet of tagged targets, storing the 364-- dependencies as we go. 365flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) 366flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where 367 untag (depMap, pdTagged) accum = case (pdTagged, accum) of 368 (Lib _, (Just _, _)) -> userBug "Only one library expected" 369 (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) 370 (SubComp n c, (mb_lib, comps)) 371 | any ((== n) . fst) comps -> 372 userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" 373 | otherwise -> (mb_lib, (n, redoBD c) : comps) 374 (PDNull, x) -> x -- actually this should not happen, but let's be liberal 375 where 376 redoBD :: L.HasBuildInfo a => a -> a 377 redoBD = set L.targetBuildDepends $ fromDepMap depMap 378 379------------------------------------------------------------------------------ 380-- Convert GenericPackageDescription to PackageDescription 381-- 382 383data PDTagged = Lib Library 384 | SubComp UnqualComponentName Component 385 | PDNull 386 deriving Show 387 388instance Monoid PDTagged where 389 mempty = PDNull 390 mappend = (<>) 391 392instance Semigroup PDTagged where 393 PDNull <> x = x 394 x <> PDNull = x 395 Lib l <> Lib l' = Lib (l <> l') 396 SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') 397 _ <> _ = cabalBug "Cannot combine incompatible tags" 398 399-- | Create a package description with all configurations resolved. 400-- 401-- This function takes a `GenericPackageDescription` and several environment 402-- parameters and tries to generate `PackageDescription` by finding a flag 403-- assignment that result in satisfiable dependencies. 404-- 405-- It takes as inputs a not necessarily complete specifications of flags 406-- assignments, an optional package index as well as platform parameters. If 407-- some flags are not assigned explicitly, this function will try to pick an 408-- assignment that causes this function to succeed. The package index is 409-- optional since on some platforms we cannot determine which packages have 410-- been installed before. When no package index is supplied, every dependency 411-- is assumed to be satisfiable, therefore all not explicitly assigned flags 412-- will get their default values. 413-- 414-- This function will fail if it cannot find a flag assignment that leads to 415-- satisfiable dependencies. (It will not try alternative assignments for 416-- explicitly specified flags.) In case of failure it will return the missing 417-- dependencies that it encountered when trying different flag assignments. 418-- On success, it will return the package description and the full flag 419-- assignment chosen. 420-- 421-- Note that this drops any stanzas which have @buildable: False@. While 422-- this is arguably the right thing to do, it means we give bad error 423-- messages in some situations, see #3858. 424-- 425finalizePD :: 426 FlagAssignment -- ^ Explicitly specified flag assignments 427 -> ComponentRequestedSpec 428 -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of 429 -- available packages? If this is unknown then use 430 -- True. 431 -> Platform -- ^ The 'Arch' and 'OS' 432 -> CompilerInfo -- ^ Compiler information 433 -> [PackageVersionConstraint] -- ^ Additional constraints 434 -> GenericPackageDescription 435 -> Either [Dependency] 436 (PackageDescription, FlagAssignment) 437 -- ^ Either missing dependencies or the resolved package 438 -- description along with the flag assignments chosen. 439finalizePD userflags enabled satisfyDep 440 (Platform arch os) impl constraints 441 (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do 442 (targetSet, flagVals) <- 443 resolveWithFlags flagChoices enabled os arch impl constraints condTrees check 444 let 445 (mb_lib, comps) = flattenTaggedTargets targetSet 446 mb_lib' = fmap libFillInDefaults mb_lib 447 comps' = flip map comps $ \(n,c) -> foldComponent 448 (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n 449 , libExposed = False }) 450 (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) 451 (\e -> CExe (exeFillInDefaults e) { exeName = n }) 452 (\t -> CTest (testFillInDefaults t) { testName = n }) 453 (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) 454 c 455 (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' 456 return ( pkg { library = mb_lib' 457 , subLibraries = sub_libs' 458 , foreignLibs = flibs' 459 , executables = exes' 460 , testSuites = tests' 461 , benchmarks = bms' 462 } 463 , flagVals ) 464 where 465 -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data 466 condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) 467 ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 468 ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 469 ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 470 ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 471 ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 472 473 flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags 474 d2c manual n b = case lookupFlagAssignment n userflags of 475 Just val -> [val] 476 Nothing 477 | manual -> [b] 478 | otherwise -> [b, not b] 479 --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices 480 check ds = let missingDeps = filter (not . satisfyDep) ds 481 in if null missingDeps 482 then DepOk 483 else MissingDeps missingDeps 484 485{- 486let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) 487let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) 488 489let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] 490let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index 491let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds 492resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... 493resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... 494-} 495 496-- | Flatten a generic package description by ignoring all conditions and just 497-- join the field descriptors into on package description. Note, however, 498-- that this may lead to inconsistent field values, since all values are 499-- joined into one field, which may not be possible in the original package 500-- description, due to the use of exclusive choices (if ... else ...). 501-- 502-- TODO: One particularly tricky case is defaulting. In the original package 503-- description, e.g., the source directory might either be the default or a 504-- certain, explicitly set path. Since defaults are filled in only after the 505-- package has been resolved and when no explicit value has been set, the 506-- default path will be missing from the package description returned by this 507-- function. 508flattenPackageDescription :: GenericPackageDescription -> PackageDescription 509flattenPackageDescription 510 (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = 511 pkg { library = mlib 512 , subLibraries = reverse sub_libs 513 , foreignLibs = reverse flibs 514 , executables = reverse exes 515 , testSuites = reverse tests 516 , benchmarks = reverse bms 517 } 518 where 519 mlib = f <$> mlib0 520 where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } 521 sub_libs = flattenLib <$> sub_libs0 522 flibs = flattenFLib <$> flibs0 523 exes = flattenExe <$> exes0 524 tests = flattenTst <$> tests0 525 bms = flattenBm <$> bms0 526 flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) 527 { libName = LSubLibName n, libExposed = False } 528 flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) 529 { foreignLibName = n } 530 flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) 531 { exeName = n } 532 flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) 533 { testName = n } 534 flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) 535 { benchmarkName = n } 536 537-- This is in fact rather a hack. The original version just overrode the 538-- default values, however, when adding conditions we had to switch to a 539-- modifier-based approach. There, nothing is ever overwritten, but only 540-- joined together. 541-- 542-- This is the cleanest way i could think of, that doesn't require 543-- changing all field parsing functions to return modifiers instead. 544libFillInDefaults :: Library -> Library 545libFillInDefaults lib@(Library { libBuildInfo = bi }) = 546 lib { libBuildInfo = biFillInDefaults bi } 547 548flibFillInDefaults :: ForeignLib -> ForeignLib 549flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = 550 flib { foreignLibBuildInfo = biFillInDefaults bi } 551 552exeFillInDefaults :: Executable -> Executable 553exeFillInDefaults exe@(Executable { buildInfo = bi }) = 554 exe { buildInfo = biFillInDefaults bi } 555 556testFillInDefaults :: TestSuite -> TestSuite 557testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = 558 tst { testBuildInfo = biFillInDefaults bi } 559 560benchFillInDefaults :: Benchmark -> Benchmark 561benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = 562 bm { benchmarkBuildInfo = biFillInDefaults bi } 563 564biFillInDefaults :: BuildInfo -> BuildInfo 565biFillInDefaults bi = 566 if null (hsSourceDirs bi) 567 then bi { hsSourceDirs = [sameDirectory] } 568 else bi 569 570-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ 571-- to all nested 'BuildInfo'/'SetupBuildInfo' values. 572transformAllBuildInfos :: (BuildInfo -> BuildInfo) 573 -> (SetupBuildInfo -> SetupBuildInfo) 574 -> GenericPackageDescription 575 -> GenericPackageDescription 576transformAllBuildInfos onBuildInfo onSetupBuildInfo = 577 over L.traverseBuildInfos onBuildInfo 578 . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo 579 580-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested 581-- @build-depends@ fields. 582transformAllBuildDepends :: (Dependency -> Dependency) 583 -> GenericPackageDescription 584 -> GenericPackageDescription 585transformAllBuildDepends f = 586 over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f 587 . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f 588 -- cannot be point-free as normal because of higher rank 589 . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) 590 591-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested 592-- @build-depends@ fields. 593transformAllBuildDependsN :: ([Dependency] -> [Dependency]) 594 -> GenericPackageDescription 595 -> GenericPackageDescription 596transformAllBuildDependsN f = 597 over (L.traverseBuildInfos . L.targetBuildDepends) f 598 . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f 599 -- cannot be point-free as normal because of higher rank 600 . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f 601