Create CondBranch type to represent CondTree triple.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Cabal/Distribution/PackageDescription/Check.hs

@@ -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 ]
 
 
 -- ------------------------------------------------------------

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -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 _      -> []

Cabal/Distribution/PackageDescription/Parse.hs

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

Cabal/Distribution/PackageDescription/Parsec.hs

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

Cabal/Distribution/PackageDescription/PrettyPrint.hs

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

Cabal/Distribution/Types/CondTree.hs

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

cabal-install/Distribution/Solver/Modular/IndexConversion.hs

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

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

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