Distribution/Types/CondTree.hs

    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DeriveFunctor #-}
    {-# LANGUAGE DeriveFoldable #-}
    {-# LANGUAGE DeriveTraversable #-}

    module Distribution.Types.CondTree (
        CondTree(..),
        CondBranch(..),
        condIfThen,
        condIfThenElse,
        mapCondTree,
        mapTreeConstrs,
        mapTreeConds,
        mapTreeData,
        traverseCondTreeV,
        traverseCondBranchV,
        extractCondition,
        simplifyCondTree,
        ignoreConditions,
    ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Types.Condition

    -- | A 'CondTree' is used to represent the conditional structure of
    -- a Cabal file, reflecting a syntax element subject to constraints,
    -- and then any number of sub-elements which may be enabled subject
    -- to some condition.  Both @a@ and @c@ are usually 'Monoid's.
    --
    -- To be more concrete, consider the following fragment of a @Cabal@
    -- file:
    --
    -- @
    -- build-depends: base >= 4.0
    -- if flag(extra)
    --     build-depends: base >= 4.2
    -- @
    --
    -- One way to represent this is to have @'CondTree' 'ConfVar'
    -- ['Dependency'] 'BuildInfo'@.  Here, 'condTreeData' represents
    -- the actual fields which are not behind any conditional, while
    -- 'condTreeComponents' recursively records any further fields
    -- which are behind a conditional.  'condTreeConstraints' records
    -- the constraints (in this case, @base >= 4.0@) which would
    -- be applied if you use this syntax; in general, this is
    -- derived off of 'targetBuildInfo' (perhaps a good refactoring
    -- would be to convert this into an opaque type, with a smart
    -- constructor that pre-computes the dependencies.)
    --
    data CondTree v c a = CondNode
        { condTreeData        :: a
        , condTreeConstraints :: c
        , condTreeComponents  :: [CondBranch v c a]
        }
        deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)

    instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)

    -- | A 'CondBranch' represents a conditional branch, e.g., @if
    -- flag(foo)@ on some syntax @a@.  It also has an optional false
    -- branch.
    --
    data CondBranch v c a = CondBranch
        { condBranchCondition :: Condition v
        , condBranchIfTrue    :: CondTree v c a
        , condBranchIfFalse   :: Maybe (CondTree v c a)
        }
        deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)

    -- This instance is written by hand because GHC 8.0.1/8.0.2 infinite
    -- loops when trying to derive it with optimizations.  See
    -- https://ghc.haskell.org/trac/ghc/ticket/13056
    instance Foldable (CondBranch v c) where
        foldMap f (CondBranch _ c Nothing) = foldMap f c
        foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a

    instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)

    condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a
    condIfThen c t = CondBranch c t Nothing

    condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
    condIfThenElse c t e = CondBranch c t (Just e)

    mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
                -> CondTree v c a -> CondTree w d b
    mapCondTree fa fc fcnd (CondNode a c ifs) =
        CondNode (fa a) (fc c) (map g ifs)
      where
        g (CondBranch cnd t me)
            = CondBranch (fcnd cnd)
                         (mapCondTree fa fc fcnd t)
                         (fmap (mapCondTree fa fc fcnd) me)

    mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
    mapTreeConstrs f = mapCondTree id f id

    mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
    mapTreeConds f = mapCondTree id id f

    mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
    mapTreeData f = mapCondTree f id id

    -- | @Traversal (CondTree v c a) (CondTree w c a) v w@
    traverseCondTreeV :: Applicative f => (v -> f w) -> CondTree v c a -> f (CondTree w c a)
    traverseCondTreeV f (CondNode a c ifs) =
        CondNode a c <$> traverse (traverseCondBranchV f) ifs

    -- | @Traversal (CondBranch v c a) (CondBranch w c a) v w@
    traverseCondBranchV :: Applicative f => (v -> f w) -> CondBranch v c a -> f (CondBranch w c a)
    traverseCondBranchV f (CondBranch cnd t me) = CondBranch
        <$> traverse f cnd
        <*> traverseCondTreeV f t
        <*> traverse (traverseCondTreeV f) me

    -- | Extract the condition matched by the given predicate from a cond tree.
    --
    -- We use this mainly for extracting buildable conditions (see the Note above),
    -- but the function is in fact more general.
    extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
    extractCondition p = go
      where
        go (CondNode x _ cs) | not (p x) = Lit False
                             | otherwise = goList cs

        goList []               = Lit True
        goList (CondBranch c t e : cs) =
          let
            ct = go t
            ce = maybe (Lit True) go e
          in
            ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs

    -- | Flattens a CondTree using a partial flag assignment.  When a condition
    -- cannot be evaluated, both branches are ignored.
    simplifyCondTree :: (Monoid a, Monoid d) =>
                        (v -> Either v Bool)
                     -> CondTree v d a
                     -> (d, a)
    simplifyCondTree env (CondNode a d ifs) =
        mconcat $ (d, a) : mapMaybe simplifyIf ifs
      where
        simplifyIf (CondBranch cnd t me) =
            case simplifyCondition cnd env of
              (Lit True, _) -> Just $ simplifyCondTree env t
              (Lit False, _) -> fmap (simplifyCondTree env) me
              _ -> Nothing

    -- | Flatten a CondTree.  This will resolve the CondTree by taking all
    --  possible paths into account.  Note that since branches represent exclusive
    --  choices this may not result in a \"sane\" result.
    ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
    ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
      where f (CondBranch _ t me) = ignoreConditions t
                           : maybeToList (fmap ignoreConditions me)