Cabal-syntax/src/Distribution/Types/CondTree.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveFoldable #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE DeriveTraversable #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7
   8 module Distribution.Types.CondTree
   9   ( CondTree (..)
  10   , CondBranch (..)
  11   , condIfThen
  12   , condIfThenElse
  13   , foldCondTree
  14   , mapCondTree
  15   , mapTreeConstrs
  16   , mapTreeConds
  17   , mapTreeData
  18   , traverseCondTreeV
  19   , traverseCondBranchV
  20   , traverseCondTreeC
  21   , traverseCondBranchC
  22   , extractCondition
  23   , simplifyCondTree
  24   , simplifyCondBranch
  25   , ignoreConditions
  26   ) where
  27
  28 import Distribution.Compat.Prelude
  29 import Prelude ()
  30
  31 import Distribution.Types.Condition
  32
  33 import qualified Distribution.Compat.Lens as L
  34
  35 -- | A 'CondTree' is used to represent the conditional structure of
  36 -- a Cabal file, reflecting a syntax element subject to constraints,
  37 -- and then any number of sub-elements which may be enabled subject
  38 -- to some condition.  Both @a@ and @c@ are usually 'Monoid's.
  39 --
  40 -- To be more concrete, consider the following fragment of a @Cabal@
  41 -- file:
  42 --
  43 -- @
  44 -- build-depends: base >= 4.0
  45 -- if flag(extra)
  46 --     build-depends: base >= 4.2
  47 -- @
  48 --
  49 -- One way to represent this is to have @'CondTree' 'ConfVar'
  50 -- ['Dependency'] 'BuildInfo'@.  Here, 'condTreeData' represents
  51 -- the actual fields which are not behind any conditional, while
  52 -- 'condTreeComponents' recursively records any further fields
  53 -- which are behind a conditional.  'condTreeConstraints' records
  54 -- the constraints (in this case, @base >= 4.0@) which would
  55 -- be applied if you use this syntax; in general, this is
  56 -- derived off of 'targetBuildInfo' (perhaps a good refactoring
  57 -- would be to convert this into an opaque type, with a smart
  58 -- constructor that pre-computes the dependencies.)
  59 data CondTree v c a = CondNode
  60   { condTreeData :: a
  61   , condTreeConstraints :: c
  62   , condTreeComponents :: [CondBranch v c a]
  63   }
  64   deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)
  65
  66 instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
  67 instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a)
  68 instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf
  69
  70 instance (Semigroup a, Semigroup c) => Semigroup (CondTree v c a) where
  71   (CondNode a c bs) <> (CondNode a' c' bs') = CondNode (a <> a') (c <> c') (bs <> bs')
  72
  73 instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where
  74   mappend = (<>)
  75   mempty = CondNode mempty mempty mempty
  76
  77 -- | A 'CondBranch' represents a conditional branch, e.g., @if
  78 -- flag(foo)@ on some syntax @a@.  It also has an optional false
  79 -- branch.
  80 data CondBranch v c a = CondBranch
  81   { condBranchCondition :: Condition v
  82   , condBranchIfTrue :: CondTree v c a
  83   , condBranchIfFalse :: Maybe (CondTree v c a)
  84   }
  85   deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)
  86
  87 -- This instance is written by hand because GHC 8.0.1/8.0.2 infinite
  88 -- loops when trying to derive it with optimizations.  See
  89 -- https://gitlab.haskell.org/ghc/ghc/-/issues/13056
  90 instance Foldable (CondBranch v c) where
  91   foldMap f (CondBranch _ c Nothing) = foldMap f c
  92   foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a
  93
  94 instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)
  95 instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a)
  96 instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf
  97
  98 condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a
  99 condIfThen c t = CondBranch c t Nothing
 100
 101 condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
 102 condIfThenElse c t e = CondBranch c t (Just e)
 103
 104 mapCondTree
 105   :: (a -> b)
 106   -> (c -> d)
 107   -> (Condition v -> Condition w)
 108   -> CondTree v c a
 109   -> CondTree w d b
 110 mapCondTree fa fc fcnd (CondNode a c ifs) =
 111   CondNode (fa a) (fc c) (map g ifs)
 112   where
 113     g (CondBranch cnd t me) =
 114       CondBranch
 115         (fcnd cnd)
 116         (mapCondTree fa fc fcnd t)
 117         (fmap (mapCondTree fa fc fcnd) me)
 118
 119 mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
 120 mapTreeConstrs f = mapCondTree id f id
 121
 122 mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
 123 mapTreeConds f = mapCondTree id id f
 124
 125 mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
 126 mapTreeData f = mapCondTree f id id
 127
 128 -- | @@Traversal@@ for the variables
 129 traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w
 130 traverseCondTreeV f (CondNode a c ifs) =
 131   CondNode a c <$> traverse (traverseCondBranchV f) ifs
 132
 133 -- | @@Traversal@@ for the variables
 134 traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w
 135 traverseCondBranchV f (CondBranch cnd t me) =
 136   CondBranch
 137     <$> traverse f cnd
 138     <*> traverseCondTreeV f t
 139     <*> traverse (traverseCondTreeV f) me
 140
 141 -- | @@Traversal@@ for the aggregated constraints
 142 traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d
 143 traverseCondTreeC f (CondNode a c ifs) =
 144   CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs
 145
 146 -- | @@Traversal@@ for the aggregated constraints
 147 traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d
 148 traverseCondBranchC f (CondBranch cnd t me) =
 149   CondBranch cnd
 150     <$> traverseCondTreeC f t
 151     <*> traverse (traverseCondTreeC f) me
 152
 153 -- | Extract the condition matched by the given predicate from a cond tree.
 154 --
 155 -- We use this mainly for extracting buildable conditions (see the Note in
 156 -- Distribution.PackageDescription.Configuration), but the function is in fact
 157 -- more general.
 158 extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
 159 extractCondition p = go
 160   where
 161     go (CondNode x _ cs)
 162       | not (p x) = Lit False
 163       | otherwise = goList cs
 164
 165     goList [] = Lit True
 166     goList (CondBranch c t e : cs) =
 167       let
 168         ct = go t
 169         ce = maybe (Lit True) go e
 170        in
 171         ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs
 172
 173 -- | Flattens a CondTree using a partial flag assignment. When a condition
 174 -- cannot be evaluated, both branches are ignored.
 175 simplifyCondTree
 176   :: (Semigroup a, Semigroup d)
 177   => (v -> Either v Bool)
 178   -> CondTree v d a
 179   -> (d, a)
 180 simplifyCondTree env (CondNode a d ifs) =
 181   foldl (<>) (d, a) $ mapMaybe (simplifyCondBranch env) ifs
 182
 183 -- | Realizes a 'CondBranch' using partial flag assignment. When a condition
 184 -- cannot be evaluated, returns 'Nothing'.
 185 simplifyCondBranch
 186   :: (Semigroup a, Semigroup d)
 187   => (v -> Either v Bool)
 188   -> CondBranch v d a
 189   -> Maybe (d, a)
 190 simplifyCondBranch env (CondBranch cnd t me) =
 191   case simplifyCondition cnd env of
 192     (Lit True, _) -> Just $ simplifyCondTree env t
 193     (Lit False, _) -> fmap (simplifyCondTree env) me
 194     _ -> Nothing
 195
 196 -- | Flatten a CondTree.  This will resolve the CondTree by taking all
 197 --  possible paths into account.  Note that since branches represent exclusive
 198 --  choices this may not result in a \"sane\" result.
 199 ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)
 200 ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
 201   where
 202     f (CondBranch _ t me) =
 203       ignoreConditions t
 204         : maybeToList (fmap ignoreConditions me)
 205
 206 -- | Flatten a CondTree. This will traverse the CondTree by taking all
 207 --  possible paths into account, but merging inclusive when two paths
 208 --  may co-exist, and exclusively when the paths are an if/else
 209 foldCondTree :: forall b c a v. b -> ((c, a) -> b) -> (b -> b -> b) -> (b -> b -> b) -> CondTree v c a -> b
 210 foldCondTree e u mergeInclusive mergeExclusive = goTree
 211   where
 212     goTree :: CondTree v c a -> b
 213     goTree (CondNode a c ifs) = u (c, a) `mergeInclusive` foldl goBranch e ifs
 214     goBranch :: b -> CondBranch v c a -> b
 215     goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt)