Commit b4fb3baa authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Edward Z. Yang
Browse files

Move generic Condition/CondTree functions to the Types module.


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent d1b84d3b
......@@ -53,46 +53,13 @@ import Distribution.Types.Component
import Distribution.Types.Dependency
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.Types.Condition
import qualified Data.Map as Map
import Data.Tree ( Tree(Node) )
------------------------------------------------------------------------------
-- | Simplify the condition and return its free variables.
simplifyCondition :: Condition c
-> (c -> Either d Bool) -- ^ (partial) variable assignment
-> (Condition d, [d])
simplifyCondition cond i = fv . walk $ cond
where
walk cnd = case cnd of
Var v -> either Var Lit (i v)
Lit b -> Lit b
CNot c -> case walk c of
Lit True -> Lit False
Lit False -> Lit True
c' -> CNot c'
COr c d -> case (walk c, walk d) of
(Lit False, d') -> d'
(Lit True, _) -> Lit True
(c', Lit False) -> c'
(_, Lit True) -> Lit True
(c',d') -> COr c' d'
CAnd c d -> case (walk c, walk d) of
(Lit False, _) -> Lit False
(Lit True, d') -> d'
(_, Lit False) -> Lit False
(c', Lit True) -> c'
(c',d') -> CAnd c' d'
-- gather free vars
fv c = (c, fv' c)
fv' c = case c of
Var v -> [v]
Lit _ -> []
CNot c' -> fv' c'
COr c1 c2 -> fv' c1 ++ fv' c2
CAnd c1 c2 -> fv' c1 ++ fv' c2
-- | 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
......@@ -157,25 +124,6 @@ parseCondition = condOr
------------------------------------------------------------------------------
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
-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
-- clarity.
data DepTestRslt d = DepOk | MissingDeps d
......@@ -335,25 +283,6 @@ addBuildableConditionPDTagged t =
-- extract the condition under which Buildable is True. The predicate determines
-- whether data under a 'CondTree' is buildable.
-- | 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
-- | Extract conditions matched by the given predicate from all cond trees in a
-- 'GenericPackageDescription'.
extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription
......@@ -398,29 +327,6 @@ toDepMap ds =
fromDepMap :: DependencyMap -> [Dependency]
fromDepMap m = [ Dependency p vr | (p,vr) <- Map.toList (unDependencyMap m) ]
-- | 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)
freeVars :: CondTree ConfVar c a -> [FlagName]
freeVars t = [ f | Flag f <- freeVars' t ]
where
......
......@@ -9,6 +9,13 @@ module Distribution.Types.CondTree (
CondBranch(..),
condIfThen,
condIfThenElse,
mapCondTree,
mapTreeConstrs,
mapTreeConds,
mapTreeData,
extractCondition,
simplifyCondTree,
ignoreConditions,
) where
import Prelude ()
......@@ -46,3 +53,64 @@ 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
-- | 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)
......@@ -6,6 +6,7 @@ module Distribution.Types.Condition (
cNot,
cAnd,
cOr,
simplifyCondition,
) where
import Prelude ()
......@@ -96,3 +97,37 @@ instance MonadPlus Condition where
mplus = mappend
instance Binary c => Binary (Condition c)
-- | Simplify the condition and return its free variables.
simplifyCondition :: Condition c
-> (c -> Either d Bool) -- ^ (partial) variable assignment
-> (Condition d, [d])
simplifyCondition cond i = fv . walk $ cond
where
walk cnd = case cnd of
Var v -> either Var Lit (i v)
Lit b -> Lit b
CNot c -> case walk c of
Lit True -> Lit False
Lit False -> Lit True
c' -> CNot c'
COr c d -> case (walk c, walk d) of
(Lit False, d') -> d'
(Lit True, _) -> Lit True
(c', Lit False) -> c'
(_, Lit True) -> Lit True
(c',d') -> COr c' d'
CAnd c d -> case (walk c, walk d) of
(Lit False, _) -> Lit False
(Lit True, d') -> d'
(_, Lit False) -> Lit False
(c', Lit True) -> c'
(c',d') -> CAnd c' d'
-- gather free vars
fv c = (c, fv' c)
fv' c = case c of
Var v -> [v]
Lit _ -> []
CNot c' -> fv' c'
COr c1 c2 -> fv' c1 ++ fv' c2
CAnd c1 c2 -> fv' c1 ++ fv' c2
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment