From a4c381a9712d60e3d157fbb256f587d7598e1712 Mon Sep 17 00:00:00 2001
From: Francesco Ariis <fa-ml@ariis.it>
Date: Sat, 2 Mar 2024 17:58:41 +0100
Subject: [PATCH] Make `check` deal correctly with multiple branches
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

`cabal check` had a problem recognising fields in presence of
multiple branches. This patch fixes the problem and does not
meaningfully increases CI time of particularly taxing tests
(like “duplicate flagged dependencies” from MemoryUsage).
---
 .../PackageDescription/Check/Conditional.hs   | 50 +++++++++++++++++--
 1 file changed, 47 insertions(+), 3 deletions(-)

diff --git a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
index 575e28c767a..1cd5353a0b1 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Conditional.hs
@@ -58,7 +58,7 @@ updateTargetAnnotation t ta = ta{taTarget = taTarget ta <> t}
 -- doc for more info).
 annotateCondTree
   :: forall a
-   . Monoid a
+   . (Eq a, Monoid a)
   => [PackageFlag] -- User flags.
   -> TargetAnnotation a
   -> CondTree ConfVar [Dependency] a
@@ -66,7 +66,8 @@ annotateCondTree
 annotateCondTree fs ta (CondNode a c bs) =
   let ta' = updateTargetAnnotation a ta
       bs' = map (annotateBranch ta') bs
-   in CondNode ta' c bs'
+      bs'' = crossAnnotateBranches defTrueFlags bs'
+   in CondNode ta' c bs''
   where
     annotateBranch
       :: TargetAnnotation a
@@ -107,12 +108,55 @@ annotateCondTree fs ta (CondNode a c bs) =
           )
           fs
 
+    defTrueFlags :: [PackageFlag]
+    defTrueFlags = filter flagDefault fs
+
+-- Propagate contextual information in CondTree branches. This is
+-- needed as CondTree is a rosetree and not a binary tree.
+crossAnnotateBranches
+  :: forall a
+   . (Eq a, Monoid a)
+  => [PackageFlag] -- `default: true` flags.
+  -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]
+  -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)]
+crossAnnotateBranches fs bs = map crossAnnBranch bs
+  where
+    crossAnnBranch
+      :: CondBranch ConfVar [Dependency] (TargetAnnotation a)
+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+    crossAnnBranch wr =
+      let
+        rs = filter (/= wr) bs
+        ts = mapMaybe realiseBranch rs
+       in
+        utaBranch (mconcat ts) wr
+
+    realiseBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> Maybe a
+    realiseBranch b =
+      let
+        -- We are only interested in True by default package flags.
+        rbf :: ConfVar -> Either ConfVar Bool
+        rbf (PackageFlag n) | elem n (map flagName fs) = Right True
+        rbf _ = Right False
+        ms = simplifyCondBranch rbf (fmap taTarget b)
+       in
+        fmap snd ms
+
+    utaBranch
+      :: a
+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+    utaBranch a (CondBranch k t mt) =
+      let utt (CondNode ka c wbs) =
+            (CondNode (updateTargetAnnotation a ka) c wbs)
+       in CondBranch k (utt t) (utt <$> mt)
+
 -- | A conditional target is a library, exe, benchmark etc., destructured
 -- in a CondTree. Traversing method: we render the branches, pass a
 -- relevant context, collect checks.
 checkCondTarget
   :: forall m a
-   . (Monad m, Monoid a)
+   . (Monad m, Eq a, Monoid a)
   => [PackageFlag] -- User flags.
   -> (a -> CheckM m ()) -- Check function (a = target).
   -> (UnqualComponentName -> a -> a)