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,
    traverseCondTreeC,
    traverseCondBranchC,
    extractCondition,
    simplifyCondTree,
    ignoreConditions,
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.Condition

import qualified Distribution.Compat.Lens as L


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

instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf

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

instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf

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@@ for the variables
traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w
traverseCondTreeV f (CondNode a c ifs) =
    CondNode a c <$> traverse (traverseCondBranchV f) ifs

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

-- | @@Traversal@@ for the aggregated constraints
traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d
traverseCondTreeC f (CondNode a c ifs) =
    CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs

-- | @@Traversal@@ for the aggregated constraints
traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d
traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd
    <$> traverseCondTreeC f t
    <*> traverse (traverseCondTreeC 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 :: (Semigroup a, Semigroup d) =>
                    (v -> Either v Bool)
                 -> CondTree v d a
                 -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
    foldl (<>) (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 :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
  where f (CondBranch _ t me) = ignoreConditions t
                       : maybeToList (fmap ignoreConditions me)