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

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3
   4 module Distribution.Types.Condition
   5   ( Condition (..)
   6   , cNot
   7   , cAnd
   8   , cOr
   9   , simplifyCondition
  10   ) where
  11
  12 import Distribution.Compat.Prelude
  13 import Prelude ()
  14
  15 -- | A boolean expression parameterized over the variable type used.
  16 data Condition c
  17   = Var c
  18   | Lit Bool
  19   | CNot (Condition c)
  20   | COr (Condition c) (Condition c)
  21   | CAnd (Condition c) (Condition c)
  22   deriving (Show, Eq, Typeable, Data, Generic)
  23
  24 -- | Boolean negation of a 'Condition' value.
  25 cNot :: Condition a -> Condition a
  26 cNot (Lit b) = Lit (not b)
  27 cNot (CNot c) = c
  28 cNot c = CNot c
  29
  30 -- | Boolean AND of two 'Condition' values.
  31 cAnd :: Condition a -> Condition a -> Condition a
  32 cAnd (Lit False) _ = Lit False
  33 cAnd _ (Lit False) = Lit False
  34 cAnd (Lit True) x = x
  35 cAnd x (Lit True) = x
  36 cAnd x y = CAnd x y
  37
  38 -- | Boolean OR of two 'Condition' values.
  39 cOr :: Eq v => Condition v -> Condition v -> Condition v
  40 cOr (Lit True) _ = Lit True
  41 cOr _ (Lit True) = Lit True
  42 cOr (Lit False) x = x
  43 cOr x (Lit False) = x
  44 cOr c (CNot d)
  45   | c == d = Lit True
  46 cOr (CNot c) d
  47   | c == d = Lit True
  48 cOr x y = COr x y
  49
  50 instance Functor Condition where
  51   f `fmap` Var c = Var (f c)
  52   _ `fmap` Lit c = Lit c
  53   f `fmap` CNot c = CNot (fmap f c)
  54   f `fmap` COr c d = COr (fmap f c) (fmap f d)
  55   f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)
  56
  57 instance Foldable Condition where
  58   f `foldMap` Var c = f c
  59   _ `foldMap` Lit _ = mempty
  60   f `foldMap` CNot c = foldMap f c
  61   f `foldMap` COr c d = foldMap f c `mappend` foldMap f d
  62   f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d
  63
  64 instance Traversable Condition where
  65   f `traverse` Var c = Var `fmap` f c
  66   _ `traverse` Lit c = pure $ Lit c
  67   f `traverse` CNot c = CNot `fmap` traverse f c
  68   f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d
  69   f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d
  70
  71 instance Applicative Condition where
  72   pure = Var
  73   (<*>) = ap
  74
  75 instance Monad Condition where
  76   return = pure
  77
  78   -- Terminating cases
  79   (>>=) (Lit x) _ = Lit x
  80   (>>=) (Var x) f = f x
  81   -- Recursing cases
  82   (>>=) (CNot x) f = CNot (x >>= f)
  83   (>>=) (COr x y) f = COr (x >>= f) (y >>= f)
  84   (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f)
  85
  86 instance Monoid (Condition a) where
  87   mempty = Lit False
  88   mappend = (<>)
  89
  90 instance Semigroup (Condition a) where
  91   (<>) = COr
  92
  93 instance Alternative Condition where
  94   empty = mempty
  95   (<|>) = mappend
  96
  97 instance MonadPlus Condition where
  98   mzero = mempty
  99   mplus = mappend
 100
 101 instance Binary c => Binary (Condition c)
 102 instance Structured c => Structured (Condition c)
 103 instance NFData c => NFData (Condition c) where rnf = genericRnf
 104
 105 -- | Simplify the condition and return its free variables.
 106 simplifyCondition
 107   :: Condition c
 108   -> (c -> Either d Bool)
 109   -- ^ (partial) variable assignment
 110   -> (Condition d, [d])
 111 simplifyCondition cond i = fv . walk $ cond
 112   where
 113     walk cnd = case cnd of
 114       Var v -> either Var Lit (i v)
 115       Lit b -> Lit b
 116       CNot c -> case walk c of
 117         Lit True -> Lit False
 118         Lit False -> Lit True
 119         c' -> CNot c'
 120       COr c d -> case (walk c, walk d) of
 121         (Lit False, d') -> d'
 122         (Lit True, _) -> Lit True
 123         (c', Lit False) -> c'
 124         (_, Lit True) -> Lit True
 125         (c', d') -> COr c' d'
 126       CAnd c d -> case (walk c, walk d) of
 127         (Lit False, _) -> Lit False
 128         (Lit True, d') -> d'
 129         (_, Lit False) -> Lit False
 130         (c', Lit True) -> c'
 131         (c', d') -> CAnd c' d'
 132     -- gather free vars
 133     fv c = (c, fv' c)
 134     fv' c = case c of
 135       Var v -> [v]
 136       Lit _ -> []
 137       CNot c' -> fv' c'
 138       COr c1 c2 -> fv' c1 ++ fv' c2
 139       CAnd c1 c2 -> fv' c1 ++ fv' c2