Merge pull request #5117 from Ericson2314/pd-component-lens

Add more lenses for PackageDescription and GenericPackageDescription

Author: Ericson2314

Cabal/Distribution/PackageDescription/Check.hs

@@ -1655,7 +1655,7 @@ checkUnicodeXFields gpd
     xfields :: [(String,String)]
     xfields = DList.runDList $ mconcat
         [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd
-        , toDListOf (L.buildInfos         . L.customFieldsBI . traverse) gpd
+        , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd
         ]
 
 -- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build.

Cabal/Distribution/PackageDescription/Configuration.hs

@@ -37,6 +37,12 @@ module Distribution.PackageDescription.Configuration (
 import Prelude ()
 import Distribution.Compat.Prelude
 
+-- lens
+import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.GenericPackageDescription.Lens as L
+import qualified Distribution.Types.PackageDescription.Lens as L
+import qualified Distribution.Types.SetupBuildInfo.Lens as L
+
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Utils
 import Distribution.Version
@@ -47,7 +53,6 @@ import Distribution.Text
 import Distribution.Compat.Lens
 import Distribution.Compat.ReadP as ReadP hiding ( char )
 import qualified Distribution.Compat.ReadP as ReadP ( char )
-import qualified Distribution.Types.BuildInfo.Lens as L
 import Distribution.Types.ComponentRequestedSpec
 import Distribution.Types.ForeignLib
 import Distribution.Types.Component
@@ -577,77 +582,17 @@ transformAllBuildInfos :: (BuildInfo -> BuildInfo)
                        -> (SetupBuildInfo -> SetupBuildInfo)
                        -> GenericPackageDescription
                        -> GenericPackageDescription
-transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'
-  where
-    onLibrary    lib  = lib { libBuildInfo  = onBuildInfo $ libBuildInfo  lib }
-    onExecutable exe  = exe { buildInfo     = onBuildInfo $ buildInfo     exe }
-    onTestSuite  tst  = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }
-    onBenchmark  bmk  = bmk { benchmarkBuildInfo =
-                                 onBuildInfo $ benchmarkBuildInfo bmk }
-
-    pd = packageDescription gpd
-    pd'  = pd {
-      library        = fmap onLibrary        (library pd),
-      subLibraries   = map  onLibrary        (subLibraries pd),
-      executables    = map  onExecutable     (executables pd),
-      testSuites     = map  onTestSuite      (testSuites pd),
-      benchmarks     = map  onBenchmark      (benchmarks pd),
-      setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)
-      }
-
-    gpd' = transformAllCondTrees onLibrary onExecutable
-           onTestSuite onBenchmark id
-           $ gpd { packageDescription = pd' }
+transformAllBuildInfos onBuildInfo onSetupBuildInfo =
+  over L.traverseBuildInfos onBuildInfo
+  . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo
 
 -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
 -- @build-depends@ fields.
 transformAllBuildDepends :: (Dependency -> Dependency)
                          -> GenericPackageDescription
                          -> GenericPackageDescription
-transformAllBuildDepends f gpd = gpd'
-  where
-    onBI  bi  = bi  { targetBuildDepends = map f $ targetBuildDepends bi }
-    onSBI stp = stp { setupDepends       = map f $ setupDepends stp      }
-
-    gpd'  = transformAllCondTrees id id id id (map f)
-            . transformAllBuildInfos onBI onSBI
-            $ gpd
-
--- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply
--- appropriate transformations to all nodes. Helper function used by
--- 'transformAllBuildDepends' and 'transformAllBuildInfos'.
-transformAllCondTrees :: (Library -> Library)
-                      -> (Executable -> Executable)
-                      -> (TestSuite -> TestSuite)
-                      -> (Benchmark -> Benchmark)
-                      -> ([Dependency] -> [Dependency])
-                      -> GenericPackageDescription -> GenericPackageDescription
-transformAllCondTrees onLibrary onExecutable
-  onTestSuite onBenchmark onDepends gpd = gpd'
-  where
-    gpd'    = gpd {
-      condLibrary        = condLib',
-      condSubLibraries   = condSubLibs',
-      condExecutables    = condExes',
-      condTestSuites     = condTests',
-      condBenchmarks     = condBenchs'
-      }
-
-    condLib    = condLibrary        gpd
-    condSubLibs = condSubLibraries  gpd
-    condExes   = condExecutables    gpd
-    condTests  = condTestSuites     gpd
-    condBenchs = condBenchmarks     gpd
-
-    condLib'    = fmap (onCondTree onLibrary) condLib
-    condSubLibs' = map (mapSnd $ onCondTree onLibrary)    condSubLibs
-    condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes
-    condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests
-    condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs
-
-    mapSnd :: (a -> b) -> (c,a) -> (c,b)
-    mapSnd = fmap
-
-    onCondTree :: (a -> b) -> CondTree v [Dependency] a
-               -> CondTree v [Dependency] b
-    onCondTree g = mapCondTree g onDepends id
+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)

Cabal/Distribution/Types/BuildInfo/Lens.hs

@@ -1,6 +1,7 @@
 module Distribution.Types.BuildInfo.Lens (
     BuildInfo,
     HasBuildInfo (..),
+    HasBuildInfos (..),
     ) where
 
 import Prelude ()
@@ -314,3 +315,6 @@ instance HasBuildInfo BuildInfo where
 
     mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s))
     {-# INLINE mixins #-}
+
+class HasBuildInfos a where
+  traverseBuildInfos :: Traversal' a BuildInfo

Cabal/Distribution/Types/CondTree.hs

@@ -15,6 +15,8 @@ module Distribution.Types.CondTree (
     mapTreeData,
     traverseCondTreeV,
     traverseCondBranchV,
+    traverseCondTreeC,
+    traverseCondBranchC,
     extractCondition,
     simplifyCondTree,
     ignoreConditions,
@@ -25,6 +27,9 @@ import Distribution.Compat.Prelude
 
 import Distribution.Types.Condition
 
+import qualified Distribution.Compat.Lens as L
+
+
 -- | A 'CondTree' is used to represent the conditional structure of
 -- a Cabal file, reflecting a syntax element subject to constraints,
 -- and then any number of sub-elements which may be enabled subject
@@ -108,18 +113,30 @@ mapTreeConds f = mapCondTree id id f
 mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
 mapTreeData f = mapCondTree f id id
 
--- | @Traversal (CondTree v c a) (CondTree w c a) v w@
-traverseCondTreeV :: Applicative f => (v -> f w) -> CondTree v c a -> f (CondTree w c a)
+-- | @@Traversal@@ for the variables
+traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w
 traverseCondTreeV f (CondNode a c ifs) =
     CondNode a c <$> traverse (traverseCondBranchV f) ifs
 
--- | @Traversal (CondBranch v c a) (CondBranch w c a) v w@
-traverseCondBranchV :: Applicative f => (v -> f w) -> CondBranch v c a -> f (CondBranch w c a)
+-- | @@Traversal@@ for the variables
+traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w
 traverseCondBranchV f (CondBranch cnd t me) = CondBranch
     <$> traverse f cnd
     <*> traverseCondTreeV f t
     <*> traverse (traverseCondTreeV f) me
 
+-- | @@Traversal@@ for the aggregated constraints
+traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d
+traverseCondTreeC f (CondNode a c ifs) =
+    CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs
+
+-- | @@Traversal@@ for the aggregated constraints
+traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d
+traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd
+    <$> traverseCondTreeC f t
+    <*> traverse (traverseCondTreeC f) me
+
+
 -- | Extract the condition matched by the given predicate from a cond tree.
 --
 -- We use this mainly for extracting buildable conditions (see the Note above),

Cabal/Distribution/Types/GenericPackageDescription.hs

@@ -36,6 +36,10 @@ import qualified Distribution.Compat.ReadP as Parse
 import qualified Distribution.Compat.CharParsing as P
 import Distribution.Compat.ReadP ((+++))
 
+-- lens
+import Distribution.Compat.Lens                     as L
+import qualified Distribution.Types.BuildInfo.Lens  as L
+
 import Distribution.Types.PackageDescription
 
 import Distribution.Types.Dependency
@@ -56,7 +60,7 @@ import Distribution.Pretty
 import Distribution.Text
 
 -- ---------------------------------------------------------------------------
--- The GenericPackageDescription type
+-- The 'GenericPackageDescription' type
 
 data GenericPackageDescription =
   GenericPackageDescription
@@ -83,6 +87,27 @@ instance Binary GenericPackageDescription
 
 instance NFData GenericPackageDescription where rnf = genericRnf
 
+emptyGenericPackageDescription :: GenericPackageDescription
+emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
+
+-- -----------------------------------------------------------------------------
+-- Traversal Instances
+
+instance L.HasBuildInfos GenericPackageDescription where
+  traverseBuildInfos f (GenericPackageDescription p a1 x1 x2 x3 x4 x5 x6) =
+    GenericPackageDescription
+        <$> L.traverseBuildInfos f p
+        <*> pure a1
+        <*> (traverse . traverse . L.buildInfo) f x1
+        <*> (traverse . L._2 . traverse . L.buildInfo) f x2
+        <*> (traverse . L._2 . traverse . L.buildInfo) f x3
+        <*> (traverse . L._2 . traverse . L.buildInfo) f x4
+        <*> (traverse . L._2 . traverse . L.buildInfo) f x5
+        <*> (traverse . L._2 . traverse . L.buildInfo) f x6
+
+-- -----------------------------------------------------------------------------
+-- The Flag' type
+
 -- | A flag can represent a feature to be included, or a way of linking
 --   a target against its dependencies, or in fact whatever you can think of.
 data Flag = MkFlag
@@ -313,6 +338,9 @@ parseFlagAssignment = mkFlagAssignment <$>
               return (f, False))
 -- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment. This symbol will be removed in Cabal-3.0 (est. Oct 2018)." #-}
 
+-- -----------------------------------------------------------------------------
+-- The 'CondVar' type
+
 -- | A @ConfVar@ represents the variable type used.
 data ConfVar = OS OS
              | Arch Arch
@@ -323,6 +351,3 @@ data ConfVar = OS OS
 instance Binary ConfVar
 
 instance NFData ConfVar where rnf = genericRnf
-
-emptyGenericPackageDescription :: GenericPackageDescription
-emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []

Cabal/Distribution/Types/GenericPackageDescription/Lens.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE Rank2Types #-}
 module Distribution.Types.GenericPackageDescription.Lens (
     GenericPackageDescription,
     Flag,
@@ -10,11 +11,6 @@ import Prelude()
 import Distribution.Compat.Prelude
 import Distribution.Compat.Lens
 
-import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription), Flag(MkFlag), FlagName, ConfVar (..))
-
--- lens
-import Distribution.Types.BuildInfo.Lens
-
 -- We import types from their packages, so we can remove unused imports
 -- and have wider inter-module dependency graph
 import Distribution.Types.CondTree (CondTree)
@@ -23,6 +19,9 @@ import Distribution.Types.Executable (Executable)
 import Distribution.Types.PackageDescription (PackageDescription)
 import Distribution.Types.Benchmark (Benchmark)
 import Distribution.Types.ForeignLib (ForeignLib)
+import Distribution.Types.GenericPackageDescription
+  ( GenericPackageDescription(GenericPackageDescription)
+  , Flag(MkFlag), FlagName, ConfVar (..))
 import Distribution.Types.Library (Library)
 import Distribution.Types.TestSuite (TestSuite)
 import Distribution.Types.UnqualComponentName (UnqualComponentName)
@@ -66,19 +65,23 @@ packageDescription :: Lens' GenericPackageDescription PackageDescription
 packageDescription f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription y1 x2 x3 x4 x5 x6 x7 x8) (f x1)
 {-# INLINE packageDescription #-}
 
--------------------------------------------------------------------------------
--- BuildInfos
--------------------------------------------------------------------------------
+allCondTrees
+  :: Applicative f
+  => (forall a. CondTree ConfVar [Dependency] a
+          -> f (CondTree ConfVar [Dependency] a))
+  -> GenericPackageDescription
+  -> f GenericPackageDescription
+allCondTrees f (GenericPackageDescription p a1 x1 x2 x3 x4 x5 x6) =
+    GenericPackageDescription
+        <$> pure p
+        <*> pure a1
+        <*> traverse f x1
+        <*> (traverse . _2) f x2
+        <*> (traverse . _2) f x3
+        <*> (traverse . _2) f x4
+        <*> (traverse . _2) f x5
+        <*> (traverse . _2) f x6
 
-buildInfos :: Traversal' GenericPackageDescription BuildInfo
-buildInfos f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) =
-    GenericPackageDescription x1 x2
-        <$> (traverse . traverse . buildInfo) f x3
-        <*> (traverse . _2 . traverse . buildInfo) f x4
-        <*> (traverse . _2 . traverse . buildInfo) f x5
-        <*> (traverse . _2 . traverse . buildInfo) f x6
-        <*> (traverse . _2 . traverse . buildInfo) f x7
-        <*> (traverse . _2 . traverse . buildInfo) f x8
 
 -------------------------------------------------------------------------------
 -- Flag

Cabal/Distribution/Types/PackageDescription.hs

@@ -64,6 +64,8 @@ import Distribution.Compat.Prelude
 
 import Control.Monad ((<=<))
 
+-- lens
+import qualified Distribution.Types.BuildInfo.Lens  as L
 import Distribution.Types.Library
 import Distribution.Types.TestSuite
 import Distribution.Types.Executable
@@ -468,3 +470,23 @@ getComponent pkg cname =
     missingComponent =
       error $ "internal error: the package description contains no "
            ++ "component corresponding to " ++ show cname
+
+-- -----------------------------------------------------------------------------
+-- Traversal Instances
+
+instance L.HasBuildInfos PackageDescription where
+  traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
+                                   x1 x2 x3 x4 x5 x6
+                                   a20 a21 a22 a23 a24) =
+    PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
+        <$> (traverse . L.buildInfo) f x1 -- library
+        <*> (traverse . L.buildInfo) f x2 -- sub libraries
+        <*> (traverse . L.buildInfo) f x3 -- executables
+        <*> (traverse . L.buildInfo) f x4 -- foreign libs
+        <*> (traverse . L.buildInfo) f x5 -- test suites
+        <*> (traverse . L.buildInfo) f x6 -- benchmarks
+        <*> pure a20                      -- data files
+        <*> pure a21                      -- data dir
+        <*> pure a22                      -- exta src files
+        <*> pure a23                      -- extra temp files
+        <*> pure a24                      -- extra doc files