Distribution/PackageDescription/Configuration.hs

    -- -fno-warn-deprecations for use of Map.foldWithKey
    {-# OPTIONS_GHC -fno-warn-deprecations #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.PackageDescription.Configuration
    -- Copyright   :  Thomas Schilling, 2007
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- This is about the cabal configurations feature. It exports
    -- 'finalizePD' and 'flattenPackageDescription' which are
    -- functions for converting 'GenericPackageDescription's down to
    -- 'PackageDescription's. It has code for working with the tree of conditions
    -- and resolving or flattening conditions.

    module Distribution.PackageDescription.Configuration (
        finalizePD,
        flattenPackageDescription,

        -- Utils
        parseCondition,
        freeVars,
        extractCondition,
        extractConditions,
        addBuildableCondition,
        mapCondTree,
        mapTreeData,
        mapTreeConds,
        mapTreeConstrs,
        transformAllBuildInfos,
        transformAllBuildDepends,
      ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    -- lens
    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.Parsec
    import Distribution.Pretty
    import Distribution.Compat.CharParsing hiding (char)
    import qualified Distribution.Compat.CharParsing as P
    import Distribution.Simple.Utils
    import Distribution.Compat.Lens
    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 qualified Data.Set as Set
    import Data.Tree ( Tree(Node) )

    ------------------------------------------------------------------------------

    -- | Simplify a configuration condition using the OS and arch names.  Returns
    --   the names of all the flags occurring in the condition.
    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
              -- fixme: treat Nothing as unknown, rather than empty list once we
              --        support partial resolution of system parameters
              Nothing     -> Right False
              Just compat -> Right (any matchImpl compat)
              where
                matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
        interp (Flag f) = Left f

    -- TODO: Add instances and check
    --
    -- prop_sC_idempotent cond a o = cond' == cond''
    --   where
    --     cond'  = simplifyCondition cond a o
    --     cond'' = simplifyCondition cond' a o
    --
    -- prop_sC_noLits cond a o = isLit res || not (hasLits res)
    --   where
    --     res = simplifyCondition cond a o
    --     hasLits (Lit _) = True
    --     hasLits (CNot c) = hasLits c
    --     hasLits (COr l r) = hasLits l || hasLits r
    --     hasLits (CAnd l r) = hasLits l || hasLits r
    --     hasLits _ = False
    --

    -- | Parse a configuration condition from a string.
    parseCondition :: CabalParsing m => m (Condition ConfVar)
    parseCondition = condOr
      where
        condOr   = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
        condAnd  = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd
        -- TODO: try?
        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 (Flag . 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

    ------------------------------------------------------------------------------

    -- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
    --   clarity.
    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')

    -- | Try to find a flag assignment that satisfies the constraints of all trees.
    --
    -- Returns either the missing dependencies, or a tuple containing the
    -- resulting data, the associated dependencies, and the chosen flag
    -- assignments.
    --
    -- In case of failure, the union of the dependencies that led to backtracking
    -- on all branches is returned.
    -- [TODO: Could also be specified with a function argument.]
    --
    -- TODO: The current algorithm is rather naive.  A better approach would be to:
    --
    -- * Rule out possible paths, by taking a look at the associated dependencies.
    --
    -- * Infer the required values for the conditions of these paths, and
    --   calculate the required domains for the variables used in these
    --   conditions.  Then picking a flag assignment would be linear (I guess).
    --
    -- This would require some sort of SAT solving, though, thus it's not
    -- implemented unless we really need it.
    --
    resolveWithFlags ::
         [(FlagName,[Bool])]
            -- ^ Domain for each flag name, will be tested in order.
      -> ComponentRequestedSpec
      -> OS      -- ^ OS as returned by Distribution.System.buildOS
      -> Arch    -- ^ Arch as returned by Distribution.System.buildArch
      -> CompilerInfo  -- ^ Compiler information
      -> [Dependency]  -- ^ Additional constraints
      -> [CondTree ConfVar [Dependency] PDTagged]
      -> ([Dependency] -> DepTestRslt [Dependency])  -- ^ Dependency test function.
      -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
           -- ^ Either the missing dependencies (error case), or a pair of
           -- (set of build targets with dependencies, chosen flag assignments)
    resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
        either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
      where
        extraConstrs = toDepMap constrs

        -- simplify trees by (partially) evaluating all conditions and converting
        -- dependencies to dependency maps.
        simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
        simplifiedTrees = map ( mapTreeConstrs toDepMap  -- convert to maps
                              . addBuildableConditionPDTagged
                              . mapTreeConds (fst . simplifyWithSysParams os arch impl))
                              trees

        -- @explore@ searches a tree of assignments, backtracking whenever a flag
        -- introduces a dependency that cannot be satisfied.  If there is no
        -- solution, @explore@ returns the union of all dependencies that caused
        -- it to backtrack.  Since the tree is constructed lazily, we avoid some
        -- computation overhead in the successful case.
        explore :: Tree FlagAssignment
                -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
        explore (Node flags ts) =
            let targetSet = TargetSet $ flip map simplifiedTrees $
                    -- apply additional constraints to all dependencies
                    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)

        -- Builds a tree of all possible flag assignments.  Internal nodes
        -- have only partial assignments.
        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

        -- special version of `mplus' for our local purposes
        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 = (\(vr, cs) -> (simplifyVersionRange vr,cs)) $ unionVersionRanges' x y
            in union `seq` Left (DepMapUnion union)

        -- `mzero'
        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

    -- | Transforms a 'CondTree' by putting the input under the "then" branch of a
    -- conditional that is True when Buildable is True. If 'addBuildableCondition'
    -- can determine that Buildable is always True, it returns the input unchanged.
    -- If Buildable is always False, it returns the empty 'CondTree'.
    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]

    -- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
    -- type.
    --
    -- It is not simply a specialisation. It is more complicated than it
    -- ought to be because of the way the 'PDTagged' monoid instance works. The
    -- @mempty = 'PDNull'@ forgets the component type, which has the effect of
    -- completely deleting components that are not buildable.
    --
    -- See <https://github.com/haskell/cabal/pull/4094> for more details.
    --
    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

    -- Note: extracting buildable conditions.
    -- --------------------------------------
    --
    -- If the conditions in a cond tree lead to Buildable being set to False, then
    -- none of the dependencies for this cond tree should actually be taken into
    -- account. On the other hand, some of the flags may only be decided in the
    -- solver, so we cannot necessarily make the decision whether a component is
    -- Buildable or not prior to solving.
    --
    -- What we are doing here is to partially evaluate a condition tree in order to
    -- extract the condition under which Buildable is True. The predicate determines
    -- whether data under a 'CondTree' is buildable.

    -- | Extract conditions matched by the given predicate from all cond trees in a
    -- 'GenericPackageDescription'.
    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
        ]

    -- | A map of dependencies that combines version ranges using 'unionVersionRanges'.
    newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, Set LibraryName) }

    -- An union of versions should correspond to an intersection of the components.
    -- The intersection may not be necessary.
    unionVersionRanges' :: (VersionRange, Set LibraryName)
                        -> (VersionRange, Set LibraryName)
                        -> (VersionRange, Set LibraryName)
    unionVersionRanges' (vra, csa) (vrb, csb) =
      (unionVersionRanges vra vrb, Set.intersection csa csb)

    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 | 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

    ------------------------------------------------------------------------------

    -- | A set of targets with their package dependencies
    newtype TargetSet a = TargetSet [(DependencyMap, a)]

    -- | Combine the target-specific dependencies in a TargetSet to give the
    -- dependencies for the package as a whole.
    overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap
    overallDependencies enabled (TargetSet targets) = mconcat depss
      where
        (depss, _) = unzip $ filter (removeDisabledSections . snd) targets
        removeDisabledSections :: PDTagged -> Bool
        -- UGH. The embedded componentName in the 'Component's here is
        -- BLANK.  I don't know whose fault this is but I'll use the tag
        -- instead. -- ezyang
        removeDisabledSections (Lib _)     = componentNameRequested
                                               enabled
                                               (CLibName LMainLibName)
        removeDisabledSections (SubComp t c)
            -- Do NOT use componentName
            = componentNameRequested enabled
            $ case c of
                CLib  _ -> CLibName (LSubLibName t)
                CFLib _ -> CFLibName   t
                CExe  _ -> CExeName    t
                CTest _ -> CTestName   t
                CBench _ -> CBenchName t
        removeDisabledSections PDNull      = True

    -- | Collect up the targets in a TargetSet of tagged targets, storing the
    -- dependencies as we go.
    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  -- actually this should not happen, but let's be liberal
        where
          redoBD :: L.HasBuildInfo a => a -> a
          redoBD = set L.targetBuildDepends $ fromDepMap depMap

    ------------------------------------------------------------------------------
    -- Convert GenericPackageDescription to PackageDescription
    --

    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"

    -- | Create a package description with all configurations resolved.
    --
    -- This function takes a `GenericPackageDescription` and several environment
    -- parameters and tries to generate `PackageDescription` by finding a flag
    -- assignment that result in satisfiable dependencies.
    --
    -- It takes as inputs a not necessarily complete specifications of flags
    -- assignments, an optional package index as well as platform parameters.  If
    -- some flags are not assigned explicitly, this function will try to pick an
    -- assignment that causes this function to succeed.  The package index is
    -- optional since on some platforms we cannot determine which packages have
    -- been installed before.  When no package index is supplied, every dependency
    -- is assumed to be satisfiable, therefore all not explicitly assigned flags
    -- will get their default values.
    --
    -- This function will fail if it cannot find a flag assignment that leads to
    -- satisfiable dependencies.  (It will not try alternative assignments for
    -- explicitly specified flags.)  In case of failure it will return the missing
    -- dependencies that it encountered when trying different flag assignments.
    -- On success, it will return the package description and the full flag
    -- assignment chosen.
    --
    -- Note that this drops any stanzas which have @buildable: False@.  While
    -- this is arguably the right thing to do, it means we give bad error
    -- messages in some situations, see #3858.
    --
    finalizePD ::
         FlagAssignment  -- ^ Explicitly specified flag assignments
      -> ComponentRequestedSpec
      -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
                              -- available packages?  If this is unknown then use
                              -- True.
      -> Platform      -- ^ The 'Arch' and 'OS'
      -> CompilerInfo  -- ^ Compiler information
      -> [Dependency]  -- ^ Additional constraints
      -> GenericPackageDescription
      -> Either [Dependency]
                (PackageDescription, FlagAssignment)
                 -- ^ Either missing dependencies or the resolved package
                 -- description along with the flag assignments chosen.
    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 = 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
        -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
        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]
        --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
        check ds     = let missingDeps = filter (not . satisfyDep) ds
                       in if null missingDeps
                          then DepOk
                          else MissingDeps missingDeps

    {-
    let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
    let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])

    let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]
    let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index
    let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds
    resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks   ===>  Right ...
    resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks  ===>  Left ...
    -}

    -- | Flatten a generic package description by ignoring all conditions and just
    -- join the field descriptors into on package description.  Note, however,
    -- that this may lead to inconsistent field values, since all values are
    -- joined into one field, which may not be possible in the original package
    -- description, due to the use of exclusive choices (if ... else ...).
    --
    -- TODO: One particularly tricky case is defaulting.  In the original package
    -- description, e.g., the source directory might either be the default or a
    -- certain, explicitly set path.  Since defaults are filled in only after the
    -- package has been resolved and when no explicit value has been set, the
    -- default path will be missing from the package description returned by this
    -- function.
    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 }

    -- This is in fact rather a hack.  The original version just overrode the
    -- default values, however, when adding conditions we had to switch to a
    -- modifier-based approach.  There, nothing is ever overwritten, but only
    -- joined together.
    --
    -- This is the cleanest way i could think of, that doesn't require
    -- changing all field parsing functions to return modifiers instead.
    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

    -- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@
    -- to all nested 'BuildInfo'/'SetupBuildInfo' values.
    transformAllBuildInfos :: (BuildInfo -> BuildInfo)
                           -> (SetupBuildInfo -> SetupBuildInfo)
                           -> GenericPackageDescription
                           -> GenericPackageDescription
    transformAllBuildInfos onBuildInfo onSetupBuildInfo =
      over L.traverseBuildInfos onBuildInfo
      . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo

    -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
    -- @build-depends@ fields.
    transformAllBuildDepends :: (Dependency -> Dependency)
                             -> GenericPackageDescription
                             -> GenericPackageDescription
    transformAllBuildDepends f =
      over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
      . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
      -- cannot be point-free as normal because of higher rank
      . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)