Merge pull request #11626 from leana8959/remove-duplicated-constraints

Remove duplicated constraints from CondTree

Author: mergify[bot]

Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs

@@ -28,7 +28,6 @@ module Distribution.PackageDescription.Configuration
   , mapCondTree
   , mapTreeData
   , mapTreeConds
-  , mapTreeConstrs
   , transformAllBuildInfos
   , transformAllBuildDepends
   , transformAllBuildDependsN
@@ -39,6 +38,7 @@ import Distribution.Compat.Prelude
 import Prelude ()
 
 -- lens
+import qualified Distribution.Compat.Lens as L
 import qualified Distribution.Types.BuildInfo.Lens as L
 import qualified Distribution.Types.GenericPackageDescription.Lens as L
 import qualified Distribution.Types.PackageDescription.Lens as L
@@ -64,6 +64,7 @@ import Distribution.Utils.Path (sameDirectory)
 import Distribution.Version
 
 import Data.Tree (Tree (Node))
+import Data.Tuple
 
 ------------------------------------------------------------------------------
 
@@ -192,7 +193,7 @@ resolveWithFlags
   -- ^ Compiler information
   -> [PackageVersionConstraint]
   -- ^ Additional constraints
-  -> [CondTree ConfVar [Dependency] PDTagged]
+  -> [CondTree ConfVar PDTagged]
   -> ([Dependency] -> DepTestRslt)
   -- ^ Dependency test function.
   -> Either [MissingDependency] (TargetSet PDTagged, FlagAssignment)
@@ -203,10 +204,10 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
   where
     -- simplify trees by (partially) evaluating all conditions and converting
     -- dependencies to dependency maps.
-    simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
+    simplifiedTrees :: [CondTree FlagName (PDTagged, DependencyMap)]
     simplifiedTrees =
       map
-        ( mapTreeConstrs toDepMap -- convert to maps
+        ( mapTreeData (\x -> (x, toDepMap $ L.view L.targetBuildDepends x))
             . addBuildableConditionPDTagged
             . mapTreeConds (fst . simplifyWithSysParams os arch impl)
         )
@@ -226,6 +227,7 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
               flip map simplifiedTrees $
                 -- apply additional constraints to all dependencies
                 first (`constrainBy` constrs)
+                  . swap
                   . simplifyCondTree (env flags)
           deps = overallDependencies enabled targetSet
        in case checkDeps (fromDepMap deps) of
@@ -262,15 +264,15 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
 -- can determine that Buildable is always True, it returns the input unchanged.
 -- If Buildable is always False, it returns the empty 'CondTree'.
 addBuildableCondition
-  :: (Eq v, Monoid a, Monoid c)
+  :: (Eq v, Monoid a)
   => (a -> BuildInfo)
-  -> CondTree v c a
-  -> CondTree v c a
+  -> CondTree v a
+  -> CondTree v a
 addBuildableCondition getInfo t =
   case extractCondition (buildable . getInfo) t of
     Lit True -> t
-    Lit False -> CondNode mempty mempty []
-    c -> CondNode mempty mempty [condIfThen c t]
+    Lit False -> CondNode mempty []
+    c -> CondNode mempty [condIfThen c t]
 
 -- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
 -- type.
@@ -282,16 +284,18 @@ addBuildableCondition getInfo t =
 --
 -- See <https://github.com/haskell/cabal/pull/4094> for more details.
 addBuildableConditionPDTagged
-  :: (Eq v, Monoid c)
-  => CondTree v c PDTagged
-  -> CondTree v c PDTagged
+  :: Eq v
+  => CondTree v PDTagged
+  -> CondTree v PDTagged
 addBuildableConditionPDTagged t =
   case extractCondition (buildable . getInfo) t of
     Lit True -> t
-    Lit False -> deleteConstraints t
-    c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
+    Lit False -> mapTreeData deleteConstraints t
+    c -> CondNode mempty [condIfThenElse c t (mapTreeData deleteConstraints t)]
   where
-    deleteConstraints = mapTreeConstrs (const mempty)
+    deleteConstraints (Lib lib) = Lib (L.set L.targetBuildDepends mempty lib)
+    deleteConstraints (SubComp unqualName comp) = SubComp unqualName (L.set L.targetBuildDepends mempty comp)
+    deleteConstraints PDNull = PDNull
 
     getInfo :: PDTagged -> BuildInfo
     getInfo (Lib l) = libBuildInfo l
@@ -326,10 +330,10 @@ extractConditions f gpkg =
     , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
     ]
 
-freeVars :: CondTree ConfVar c a -> [FlagName]
+freeVars :: CondTree ConfVar a -> [FlagName]
 freeVars t = [f | PackageFlag f <- freeVars' t]
   where
-    freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
+    freeVars' (CondNode _ ifs) = concatMap compfv ifs
     compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
     condfv c = case c of
       Var v -> [v]
@@ -406,6 +410,12 @@ instance Semigroup PDTagged where
   SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
   _ <> _ = cabalBug "Cannot combine incompatible tags"
 
+instance L.HasBuildInfo PDTagged where
+  buildInfo f x = case x of
+    Lib lib -> Lib <$> L.buildInfo f lib
+    SubComp name comp -> SubComp name <$> L.buildInfo f comp
+    PDNull -> PDNull <$ f mempty
+
 -- | Create a package description with all configurations resolved.
 --
 -- This function takes a `GenericPackageDescription` and several environment
@@ -554,36 +564,47 @@ flattenPackageDescription
     where
       mlib = f <$> mlib0
         where
-          f lib = (libFillInDefaults . fst . ignoreConditions $ lib){libName = LMainLibName}
+          f :: CondTree ConfVar Library -> Library
+          f lib = (libFillInDefaults . ignoreConditions $ lib){libName = LMainLibName}
       sub_libs = flattenLib <$> sub_libs0
       flibs = flattenFLib <$> flibs0
       exes = flattenExe <$> exes0
       tests = flattenTst <$> tests0
       bms = flattenBm <$> bms0
+
+      flattenLib :: (UnqualComponentName, CondTree ConfVar Library) -> Library
       flattenLib (n, t) =
         libFillInDefaults $
-          (fst $ ignoreConditions t)
+          (ignoreConditions t)
             { libName = LSubLibName n
             , libExposed = False
             }
+
+      flattenFLib :: (UnqualComponentName, CondTree ConfVar ForeignLib) -> ForeignLib
       flattenFLib (n, t) =
         flibFillInDefaults $
-          (fst $ ignoreConditions t)
+          (ignoreConditions t)
             { foreignLibName = n
             }
+
+      flattenExe :: (UnqualComponentName, CondTree ConfVar Executable) -> Executable
       flattenExe (n, t) =
         exeFillInDefaults $
-          (fst $ ignoreConditions t)
+          (ignoreConditions t)
             { exeName = n
             }
+
+      flattenTst :: (UnqualComponentName, CondTree ConfVar TestSuite) -> TestSuite
       flattenTst (n, t) =
         testFillInDefaults $
-          (fst $ ignoreConditions t)
+          (ignoreConditions t)
             { testName = n
             }
+
+      flattenBm :: (UnqualComponentName, CondTree ConfVar Benchmark) -> Benchmark
       flattenBm (n, t) =
         benchFillInDefaults $
-          (fst $ ignoreConditions t)
+          (ignoreConditions t)
             { benchmarkName = n
             }
 
@@ -640,8 +661,6 @@ transformAllBuildDepends
 transformAllBuildDepends f =
   over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
     . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
-    -- cannot be point-free as normal because of higher rank
-    . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)
 
 -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
 -- @build-depends@ fields.
@@ -652,5 +671,3 @@ transformAllBuildDependsN
 transformAllBuildDependsN f =
   over (L.traverseBuildInfos . L.targetBuildDepends) f
     . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f
-    -- cannot be point-free as normal because of higher rank
-    . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f

Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs

@@ -263,7 +263,7 @@ goSections specVer = traverse_ process
       -> Map String CondTreeBuildInfo
       -- \^ common stanzas
       -> [Field Position]
-      -> ParseResult src (CondTree ConfVar [Dependency] a)
+      -> ParseResult src (CondTree ConfVar a)
     parseCondTree' = parseCondTreeWithCommonStanzas specVer
 
     parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser src ()
@@ -478,11 +478,9 @@ parseCondTree
   -- ^ common stanzas
   -> (BuildInfo -> a)
   -- ^ constructor from buildInfo
-  -> (a -> [Dependency])
-  -- ^ condition extractor
   -> [Field Position]
-  -> ParseResult src (CondTree ConfVar [Dependency] a)
-parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
+  -> ParseResult src (CondTree ConfVar a)
+parseCondTree v hasElif grammar commonStanzas fromBuildInfo = go
   where
     go fields0 = do
       (fields, endo) <-
@@ -493,9 +491,9 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
       let (fs, ss) = partitionFields fields
       x <- parseFieldGrammar v fs grammar
       branches <- concat <$> traverse parseIfs ss
-      return $ endo $ CondNode x (cond x) branches
+      return $ endo $ CondNode x branches
 
-    parseIfs :: [Section Position] -> ParseResult src [CondBranch ConfVar [Dependency] a]
+    parseIfs :: [Section Position] -> ParseResult src [CondBranch ConfVar a]
     parseIfs [] = return []
     parseIfs (MkSection (Name pos name) test fields : sections) | name == "if" = do
       test' <- parseConditionConfVar (startOfSection (incPos 2 pos) test) test
@@ -508,7 +506,7 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
 
     parseElseIfs
       :: [Section Position]
-      -> ParseResult src (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
+      -> ParseResult src (Maybe (CondTree ConfVar a), [CondBranch ConfVar a])
     parseElseIfs [] = return (Nothing, [])
     parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
       unless (null args) $
@@ -525,7 +523,7 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
           (elseFields, sections') <- parseElseIfs sections
           -- we parse an empty 'Fields', to get empty value for a node
           a <- parseFieldGrammar v mempty grammar
-          return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
+          return (Just $ CondNode a [CondBranch test' fields' elseFields], sections')
     parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
       parseWarning pos PWTInvalidSubsection "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
       (,) Nothing <$> parseIfs sections
@@ -593,7 +591,7 @@ with new AST, this all need to be rewritten.
 -- The approach is simple, and have good properties:
 --
 -- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
-type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
+type CondTreeBuildInfo = CondTree ConfVar BuildInfo
 
 -- | Create @a@ from 'BuildInfo'.
 -- This class is used to implement common stanza parsing.
@@ -635,10 +633,10 @@ parseCondTreeWithCommonStanzas
   -> Map String CondTreeBuildInfo
   -- ^ common stanzas
   -> [Field Position]
-  -> ParseResult src (CondTree ConfVar [Dependency] a)
+  -> ParseResult src (CondTree ConfVar a)
 parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do
   (fields', endo) <- processImports v fromBuildInfo commonStanzas fields
-  x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
+  x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo fields'
   return (endo x)
   where
     hasElif = specHasElif v
@@ -652,7 +650,7 @@ processImports
   -> Map String CondTreeBuildInfo
   -- ^ common stanzas
   -> [Field Position]
-  -> ParseResult src ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
+  -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a)
 processImports v fromBuildInfo commonStanzas = go []
   where
     hasCommonStanzas = specHasCommonStanzas v
@@ -695,11 +693,11 @@ warnImport _ f = pure (Just f)
 mergeCommonStanza
   :: L.HasBuildInfo a
   => (BuildInfo -> a)
-  -> CondTree ConfVar [Dependency] BuildInfo
-  -> CondTree ConfVar [Dependency] a
-  -> CondTree ConfVar [Dependency] a
-mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
-  CondNode x' (x' ^. L.targetBuildDepends) cs'
+  -> CondTree ConfVar BuildInfo
+  -> CondTree ConfVar a
+  -> CondTree ConfVar a
+mergeCommonStanza fromBuildInfo (CondNode bi bis) (CondNode x cs) =
+  CondNode x' cs'
   where
     -- new value is old value with buildInfo field _prepended_.
     x' = x & L.buildInfo %~ (bi <>)
@@ -712,21 +710,21 @@ mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
 -------------------------------------------------------------------------------
 
 -- Check that a property holds on all branches of a condition tree
-onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
+onAllBranches :: forall v a. Monoid a => (a -> Bool) -> CondTree v a -> Bool
 onAllBranches p = go mempty
   where
     -- If the current level of the tree satisfies the property, then we are
     -- done. If not, then one of the conditional branches below the current node
     -- must satisfy it. Each node may have multiple immediate children; we only
     -- one need one to satisfy the property because the configure step uses
     -- 'mappend' to join together the results of flag resolution.
-    go :: a -> CondTree v c a -> Bool
+    go :: a -> CondTree v a -> Bool
     go acc ct =
       let acc' = acc `mappend` condTreeData ct
        in p acc' || any (goBranch acc') (condTreeComponents ct)
 
     -- Both the 'true' and the 'false' block must satisfy the property.
-    goBranch :: a -> CondBranch v c a -> Bool
+    goBranch :: a -> CondBranch v a -> Bool
     goBranch _ (CondBranch _ _ Nothing) = False
     goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
 
@@ -750,7 +748,7 @@ checkForUndefinedFlags gpd = do
       "These flags are used without having been defined: "
         ++ intercalate ", " [unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags]
   where
-    f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)
+    f :: CondTree ConfVar a -> Const (Set.Set FlagName) (CondTree ConfVar a)
     f ct = Const (Set.fromList (freeVars ct))
 
 -- | Since @cabal-version: 1.24@ one can specify @custom-setup@.