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

Create CondBranch type to represent CondTree triple.


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent c373c77e
......@@ -46,6 +46,7 @@ import Distribution.Simple.CCompiler
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.Dependency
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import Distribution.Version
import Distribution.Package
......@@ -1495,7 +1496,7 @@ checkConditionals pkg =
++ concatMap (fvs . snd) (condTestSuites pkg)
++ concatMap (fvs . snd) (condBenchmarks pkg)
fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables
compfv (c, ct, mct) = condfv c ++ fvs ct ++ maybe [] fvs mct
compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct
condfv c = case c of
Var v -> [v]
Lit _ -> []
......@@ -1624,11 +1625,11 @@ checkDevelopmentOnlyFlags pkg =
: concat
[ go (condition:conditions) ifThen
| (condition, ifThen, _) <- condTreeComponents condNode ]
| (CondBranch condition ifThen _) <- condTreeComponents condNode ]
++ concat
[ go (condition:conditions) elseThen
| (condition, _, Just elseThen) <- condTreeComponents condNode ]
| (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ]
-- ------------------------------------------------------------
......
......@@ -52,6 +52,7 @@ import Distribution.Types.ForeignLib
import Distribution.Types.Component
import Distribution.Types.Dependency
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import qualified Data.Map as Map
import Data.Tree ( Tree(Node) )
......@@ -161,8 +162,10 @@ mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
mapCondTree fa fc fcnd (CondNode a c ifs) =
CondNode (fa a) (fc c) (map g ifs)
where
g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,
fmap (mapCondTree fa fc fcnd) me)
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
......@@ -290,7 +293,7 @@ addBuildableCondition getInfo t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
Lit False -> CondNode mempty mempty []
c -> CondNode mempty mempty [(c, t, Nothing)]
c -> CondNode mempty mempty [condIfThen c t]
-- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
-- type.
......@@ -309,7 +312,7 @@ addBuildableConditionPDTagged t =
case extractCondition (buildable . getInfo) t of
Lit True -> t
Lit False -> deleteConstraints t
c -> CondNode mempty mempty [(c, t, Just (deleteConstraints t))]
c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
where
deleteConstraints = mapTreeConstrs (const mempty)
......@@ -344,7 +347,7 @@ extractCondition p = go
| otherwise = goList cs
goList [] = Lit True
goList ((c, t, e) : cs) =
goList (CondBranch c t e : cs) =
let
ct = go t
ce = maybe (Lit True) go e
......@@ -404,7 +407,7 @@ simplifyCondTree :: (Monoid a, Monoid d) =>
simplifyCondTree env (CondNode a d ifs) =
mconcat $ (d, a) : mapMaybe simplifyIf ifs
where
simplifyIf (cnd, t, me) =
simplifyIf (CondBranch cnd t me) =
case simplifyCondition cnd env of
(Lit True, _) -> Just $ simplifyCondTree env t
(Lit False, _) -> fmap (simplifyCondTree env) me
......@@ -415,14 +418,14 @@ simplifyCondTree env (CondNode a d ifs) =
-- 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 (_, t, me) = ignoreConditions t
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
freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
condfv c = case c of
Var v -> [v]
Lit _ -> []
......
......@@ -53,6 +53,7 @@ import Distribution.Types.Dependency
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibType
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.ParseUtils hiding (parseFields)
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
......@@ -1117,7 +1118,7 @@ parsePackageDescription file = do
[] -> return Nothing
es -> do fs <- collectFields parser es
return (Just fs)
return (cnd, t', e')
return (CondBranch cnd t' e')
processIfs _ = cabalBug "processIfs called with wrong field type"
parseLibFields :: [Field] -> PM Library
......@@ -1181,9 +1182,9 @@ onAllBranches p = go mempty
in p acc' || any (goBranch acc') (condTreeComponents ct)
-- Both the 'true' and the 'false' block must satisfy the property.
goBranch :: a -> (cond, CondTree v c a, Maybe (CondTree v c a)) -> Bool
goBranch _ (_, _, Nothing) = False
goBranch acc (_, t, Just e) = go acc t && go acc e
goBranch :: a -> CondBranch v c a -> Bool
goBranch _ (CondBranch _ _ Nothing) = False
goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
-- | Parse a list of fields, given a list of field descriptions,
-- a structure to accumulate the parsed fields, and a function
......
......@@ -50,6 +50,7 @@ import Distribution.Simple.Utils
(die, fromUTF8BS, warn)
import Distribution.Text (display)
import Distribution.Types.ForeignLib
import Distribution.Types.CondTree
import Distribution.Types.UnqualComponentName
(UnqualComponentName, mkUnqualComponentName)
import Distribution.Verbosity (Verbosity)
......@@ -400,7 +401,7 @@ parseFields descrs _unknown = foldM go
fieldParsers = Map.fromList $
map (\x -> (fieldName x, fieldParser x)) descrs
type C c a = (Condition ConfVar, CondTree ConfVar c a, Maybe (CondTree ConfVar c a))
type C c a = CondBranch ConfVar c a
parseCondTree
:: forall a c.
......@@ -460,10 +461,10 @@ parseCondTree descs unknown cond ini = impl
alt' <- case alt of
[] -> pure Nothing
_ -> Just <$> impl alt
let ieb = (tes, con, alt')
let ieb = (CondBranch tes con alt')
goFields (x, SnocList.snoc xs ieb) fields
goElse tes con (x, xs) fields = do
let ieb = (tes, con, Nothing)
let ieb = (CondBranch tes con Nothing)
goFields (x, SnocList.snoc xs ieb) fields
fieldParsers :: Map FieldName (a -> FieldParser a)
......
......@@ -32,6 +32,7 @@ import Distribution.Compat.Prelude
import Distribution.Types.Dependency
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName
import Distribution.Types.CondTree
import Distribution.PackageDescription
import Distribution.Simple.Utils
......@@ -239,8 +240,8 @@ ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
else res
where
-- TODO: this ends up printing trailing spaces when combined with nest.
ppIf (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree
ppIf (c, thenTree, Nothing) = ppIf' it ppIt c thenTree
ppIf (CondBranch c thenTree (Just elseTree)) = ppIfElse it ppIt c thenTree elseTree
ppIf (CondBranch c thenTree Nothing) = ppIf' it ppIt c thenTree
ppIfCondition :: (Condition ConfVar) -> Doc
ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c)
......
......@@ -6,6 +6,9 @@
module Distribution.Types.CondTree (
CondTree(..),
CondBranch(..),
condIfThen,
condIfThenElse,
) where
import Prelude ()
......@@ -16,10 +19,30 @@ import Distribution.Types.Condition
data CondTree v c a = CondNode
{ condTreeData :: a
, condTreeConstraints :: c
, condTreeComponents :: [( Condition v
, CondTree v c a
, Maybe (CondTree v c a))]
, 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)
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)
......@@ -16,6 +16,7 @@ import Distribution.Types.Dependency -- from Cabal
import Distribution.Types.LegacyExeDependency -- from Cabal
import Distribution.Types.PkgconfigDependency -- from Cabal
import Distribution.Types.UnqualComponentName -- from Cabal
import Distribution.Types.CondTree -- from Cabal
import Distribution.PackageDescription as PD -- from Cabal
import Distribution.PackageDescription.Configuration as PDC
import qualified Distribution.Simple.PackageIndex as SI
......@@ -256,10 +257,9 @@ convBranch :: OS -> Arch -> CompilerInfo ->
(a -> BuildInfo) ->
IPNs ->
SolveExecutables ->
(Condition ConfVar,
CondTree ConfVar [Dependency] a,
Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN
convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (c', t', mf') =
CondBranch ConfVar [Dependency] a ->
FlaggedDeps Component PN
convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (CondBranch c' t' mf') =
go c' ( convCondTree os arch cinfo pi fds comp getInfo ipns sexes t')
(maybe [] (convCondTree os arch cinfo pi fds comp getInfo ipns sexes) mf')
where
......
......@@ -51,6 +51,7 @@ import qualified Distribution.Types.Dependency as C
import qualified Distribution.Types.LegacyExeDependency as C
import qualified Distribution.Types.PkgconfigDependency as C
import qualified Distribution.Types.UnqualComponentName as C
import qualified Distribution.Types.CondTree as C
import qualified Distribution.PackageDescription as C
import qualified Distribution.PackageDescription.Check as C
import qualified Distribution.Simple.PackageIndex as C.PackageIndex
......@@ -257,9 +258,7 @@ type ExampleDb = [Either ExampleInstalled ExampleAvailable]
type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a
type DependencyComponent a = ( C.Condition C.ConfVar
, DependencyTree a
, Maybe (DependencyTree a))
type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a
exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)
......@@ -414,7 +413,7 @@ exAvSrcPkg ex =
goComponents :: [DependencyComponent C.BuildInfo]
-> [DependencyComponent a]
goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps]
goComponents comps = [C.CondBranch cond (go t) (go <$> me) | C.CondBranch cond t me <- comps]
mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo
mkBuildInfoTree NotBuildable =
......@@ -455,13 +454,11 @@ exAvSrcPkg ex =
mkDirect (dep, v) = C.Dependency (C.mkPackageName dep) $ mkVersion $v
mkFlagged :: (ExampleFlagName, Dependencies, Dependencies)
-> ( C.Condition C.ConfVar
, DependencyTree C.BuildInfo
, Maybe (DependencyTree C.BuildInfo))
mkFlagged (f, a, b) = ( C.Var (C.Flag (C.mkFlagName f))
, mkBuildInfoTree a
, Just (mkBuildInfoTree b)
)
-> DependencyComponent C.BuildInfo
mkFlagged (f, a, b) =
C.CondBranch (C.Var (C.Flag (C.mkFlagName f)))
(mkBuildInfoTree a)
(Just (mkBuildInfoTree b))
-- Split a set of dependencies into direct dependencies and flagged
-- dependencies. A direct dependency is a tuple of the name of package and
......
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