Improve stateConfig lense usage

jgotoh · Jul 26, 2024 · 7a5b831 · 7a5b831
1 parent 16733e1
commit 7a5b831
Show file tree

Hide file tree

Showing 2 changed files with 18 additions and 10 deletions.
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs
@@ -7,7 +7,7 @@ import Distribution.Client.IndexUtils.ActiveRepos
   ( ActiveRepos
   )
 import Distribution.Client.IndexUtils.IndexState (TotalIndexState)
-import Distribution.Client.ProjectConfig.Types (MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared)
+import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared)
 import qualified Distribution.Client.ProjectConfig.Types as T
 import Distribution.Client.Targets (UserConstraint)
 import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder)
@@ -304,6 +304,14 @@ projectConfigMultiRepl :: Lens' ProjectConfigShared (Flag Bool)
 projectConfigMultiRepl f s = fmap (\x -> s{T.projectConfigMultiRepl = x}) (f (T.projectConfigMultiRepl s))
 {-# INLINEABLE projectConfigMultiRepl #-}
 
+packageConfigProgramPaths :: Lens' PackageConfig (MapLast String FilePath)
+packageConfigProgramPaths f s = fmap (\x -> s{T.packageConfigProgramPaths = x}) (f (T.packageConfigProgramPaths s))
+{-# INLINEABLE packageConfigProgramPaths #-}
+
+packageConfigProgramArgs :: Lens' PackageConfig (MapMappend String [String])
+packageConfigProgramArgs f s = fmap (\x -> s{T.packageConfigProgramArgs = x}) (f (T.packageConfigProgramArgs s))
+{-# INLINEABLE packageConfigProgramArgs #-}
+
 packageConfigProgramPathExtra :: Lens' PackageConfig (NubList FilePath)
 packageConfigProgramPathExtra f s = fmap (\x -> s{T.packageConfigProgramPathExtra = x}) (f (T.packageConfigProgramPathExtra s))
 {-# INLINEABLE packageConfigProgramPathExtra #-}

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
@@ -247,17 +247,17 @@ parseSection programDb (MkSection (Name pos name) args secFields)
       verifyNullSubsections
       verifyNullSectionArgs
       srp <- lift $ parseFieldGrammar cabalSpec fields sourceRepositoryPackageGrammar
-      stateConfig . L.projectPackagesRepo %= (++ [srp])
+      stateConfig . L.projectPackagesRepo %= (<> [srp])
   | name == "program-options" = do
       verifyNullSubsections
       verifyNullSectionArgs
-      opts <- lift $ parseProgramArgs Warn programDb fields
-      stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramArgs = (opts <> packageConfigProgramArgs cfg)})
+      opts' <- lift $ parseProgramArgs Warn programDb fields
+      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>)
   | name == "program-locations" = do
       verifyNullSubsections
       verifyNullSectionArgs
-      paths <- lift $ parseProgramPaths Warn programDb fields
-      stateConfig . L.projectConfigLocalPackages %= (\cfg -> cfg{packageConfigProgramPaths = (paths <> packageConfigProgramPaths cfg)})
+      paths' <- lift $ parseProgramPaths Warn programDb fields
+      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>)
   | name == "repository" = do
       verifyNullSubsections
       mRepoName <- lift $ parseRepoName pos args
@@ -266,19 +266,19 @@ parseSection programDb (MkSection (Name pos name) args secFields)
           remoteRepo <- lift $ parseFieldGrammar cabalSpec fields (remoteRepoGrammar repoName)
           remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo
           case remoteOrLocalRepo of
-            Left local -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigLocalNoIndexRepos = (projectConfigLocalNoIndexRepos pcs <> toNubList [local])})
-            Right remote -> stateConfig . L.projectConfigShared %= (\pcs -> pcs{projectConfigRemoteRepos = (projectConfigRemoteRepos pcs <> toNubList [remote])})
+            Left local -> stateConfig . L.projectConfigShared . L.projectConfigLocalNoIndexRepos %= (<> toNubList [local])
+            Right remote -> stateConfig . L.projectConfigShared . L.projectConfigRemoteRepos %= (<> toNubList [remote])
         Nothing -> lift $ parseFailure pos "a 'repository' section requires the repository name as an argument"
   | name == "package" = do
       verifyNullSubsections
       package <- lift $ parsePackageName pos args
       case package of
         Just AllPackages -> do
           packageCfg' <- parsePackageConfig
-          stateConfig . L.projectConfigAllPackages %= (\packageCfg -> packageCfg' <> packageCfg)
+          stateConfig . L.projectConfigAllPackages %= (packageCfg' <>)
         Just (SpecificPackage packageName) -> do
           packageCfg <- parsePackageConfig
-          stateConfig . L.projectConfigSpecificPackage %= (\spcs -> spcs <> MapMappend (Map.singleton packageName packageCfg))
+          stateConfig . L.projectConfigSpecificPackage %= (<> MapMappend (Map.singleton packageName packageCfg))
         Nothing -> do
           lift $ parseWarning pos PWTUnknownSection "target package name or * required"
           return ()