Merge pull request #9792 from haskell/mergify/bp/3.12/pr-9768

Make `check` recognise `main-is` in conditional branches (backport #9768)

Author: mergify[bot]

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

@@ -21,6 +21,7 @@ module Distribution.Types.CondTree
   , traverseCondBranchC
   , extractCondition
   , simplifyCondTree
+  , simplifyCondBranch
   , ignoreConditions
   ) where
 
@@ -169,21 +170,28 @@ extractCondition p = go
        in
         ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs
 
--- | Flattens a CondTree using a partial flag assignment.  When a condition
+-- | Flattens a CondTree using a partial flag assignment. When a condition
 -- cannot be evaluated, both branches are ignored.
 simplifyCondTree
   :: (Semigroup a, Semigroup d)
   => (v -> Either v Bool)
   -> CondTree v d a
   -> (d, a)
 simplifyCondTree env (CondNode a d ifs) =
-  foldl (<>) (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
+  foldl (<>) (d, a) $ mapMaybe (simplifyCondBranch env) ifs
+
+-- | Realizes a 'CondBranch' using partial flag assignment. When a condition
+-- cannot be evaluated, returns 'Nothing'.
+simplifyCondBranch
+  :: (Semigroup a, Semigroup d)
+  => (v -> Either v Bool)
+  -> CondBranch v d a
+  -> Maybe (d, a)
+simplifyCondBranch env (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

Cabal/src/Distribution/PackageDescription/Check/Conditional.hs

@@ -58,15 +58,16 @@ 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
   -> CondTree ConfVar [Dependency] (TargetAnnotation a)
 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
+        updateTargetAnnBranch (mconcat ts) wr
+
+    realiseBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> Maybe a
+    realiseBranch b =
+      let
+        -- We are only interested in True by default package flags.
+        realiseBranchFunction :: ConfVar -> Either ConfVar Bool
+        realiseBranchFunction (PackageFlag n) | elem n (map flagName fs) = Right True
+        realiseBranchFunction _ = Right False
+        ms = simplifyCondBranch realiseBranchFunction (fmap taTarget b)
+       in
+        fmap snd ms
+
+    updateTargetAnnBranch
+      :: a
+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+      -> CondBranch ConfVar [Dependency] (TargetAnnotation a)
+    updateTargetAnnBranch a (CondBranch k t mt) =
+      let updateTargetAnnTree (CondNode ka c wbs) =
+            (CondNode (updateTargetAnnotation a ka) c wbs)
+       in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> 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)
@@ -131,7 +175,7 @@ checkCondTarget fs cf nf (unqualName, ct) =
       :: CondTree ConfVar [Dependency] (TargetAnnotation a)
       -> CheckM m ()
     wTree (CondNode ta _ bs)
-      -- There are no branches (and [] == True) *or* every branch
+      -- There are no branches ([] == True) *or* every branch
       -- is “simple” (i.e. missing a 'condBranchIfFalse' part).
       -- This is convenient but not necessarily correct in all
       -- cases; a more precise way would be to check incompatibility

cabal-testsuite/PackageTests/Check/Cond/After/cabal.out

@@ -0,0 +1,2 @@
+# cabal check
+No errors or warnings could be found in the package.

cabal-testsuite/PackageTests/Check/Cond/After/cabal.test.hs

@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+
+-- `main-is` in both branches is not missing (after).
+main = cabalTest $
+  cabal "check" []

cabal-testsuite/PackageTests/Check/Cond/After/pkg.cabal

@@ -0,0 +1,26 @@
+cabal-version: 3.0
+name: pkg
+synopsis: synopsis
+description: description
+version: 0
+category: example
+maintainer: [email protected]
+license: GPL-3.0-or-later
+
+flag my-flag
+  description: Test for branches.
+  default: False
+  manual: True
+
+executable exe
+  if os(windows)
+    ghc-options: -pgml misc/static-libstdc++
+
+  if flag(my-flag)
+    main-is: Main.hs
+    build-depends: async, unix
+    c-sources: executable/link.c
+  else
+    main-is: ParallelMain.hs
+
+  default-language: Haskell2010

cabal-testsuite/PackageTests/Check/Cond/Before/cabal.out

@@ -0,0 +1,2 @@
+# cabal check
+No errors or warnings could be found in the package.

cabal-testsuite/PackageTests/Check/Cond/Before/cabal.test.hs

@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+
+-- `main-is` in both branches is not missing.
+main = cabalTest $
+  cabal "check" []

cabal-testsuite/PackageTests/Check/Cond/Before/pkg.cabal

@@ -0,0 +1,26 @@
+cabal-version: 3.0
+name: pkg
+synopsis: synopsis
+description: description
+version: 0
+category: example
+maintainer: [email protected]
+license: GPL-3.0-or-later
+
+flag my-flag
+  description: Test for branches.
+  default: False
+  manual: True
+
+executable exe
+  if flag(my-flag)
+    main-is: Main.hs
+    build-depends: async, unix
+    c-sources: executable/link.c
+  else
+    main-is: ParallelMain.hs
+
+  if os(windows)
+    ghc-options: -pgml misc/static-libstdc++
+
+  default-language: Haskell2010

cabal-testsuite/PackageTests/Check/Cond/Deep/cabal.out

@@ -0,0 +1,2 @@
+# cabal check
+No errors or warnings could be found in the package.

cabal-testsuite/PackageTests/Check/Cond/Deep/cabal.test.hs

@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+
+-- `main-is` in both branches is not missing (deep).
+main = cabalTest $
+  cabal "check" []