There is a better way to parse record fields (ApplicativeDo + RecordWildCards)

Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -303,27 +304,26 @@ basicFieldGrammar
      , c (MQuoted Version)
      )
   => g Basic Basic
-basicFieldGrammar =
-  mkBasic
-    <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
-    <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion
-    <*> optionalField "package-name" basicPkgName
-    <*> optionalField "lib-name" basicLibName
-    <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
-  where
-    mkBasic n v pn ln lv = Basic n v pn ln' lv'
-      where
-        ln' = maybe LMainLibName LSubLibName ln
-        -- Older GHCs (<8.8) always report installed libraries as private
+basicFieldGrammar = do
+  _basicName <- optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
+  _basicVersion <- optionalFieldDefAla "version" MQuoted basicVersion nullVersion
+  _basicPkgName <- optionalField "package-name" basicPkgName
+  _basicLibName <- maybe LMainLibName LSubLibName <$> optionalField "lib-name" basicLibName
+  _basicLibVisibility' <- optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
+  pure
+    Basic
+      { -- Older GHCs (<8.8) always report installed libraries as private
         -- because their ghc-pkg builds with an older Cabal.
         -- So we always set LibraryVisibilityPublic for main (unnamed) libs.
         -- This can be removed once we stop supporting GHC<8.8, at the
         -- condition that we keep marking main libraries as public when
         -- registering them.
-        lv' =
-          if let MungedPackageName _ mln = n
-              in -- We need to check both because on ghc<8.2 ln' will always
+        _basicLibVisibility =
+          if let MungedPackageName _ mln = _basicName
+              in -- We need to check both because on ghc<8.2 _basicLibName will always
                  -- be LMainLibName
-                 ln' == LMainLibName && mln == LMainLibName
+                 _basicLibName == LMainLibName && mln == LMainLibName
             then LibraryVisibilityPublic
-            else lv
+            else _basicLibVisibility'
+      , ..
+      }

Cabal/src/Distribution/Simple/InstallDirs.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE CApiFFI #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- |
 -- Module      :  Distribution.Simple.InstallDirs
@@ -559,25 +561,25 @@ foreign import capi unsafe "shlobj.h SHGetFolderPathW"
 -- FieldGrammar
 
 installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate))
-installDirsGrammar =
-  InstallDirs
-    <$> optionalFieldDef "prefix" installDirsPrefixLens mempty
-    <*> optionalFieldDef "bindir" installDirsBindirLens mempty
-    <*> optionalFieldDef "libdir" installDirsLibdirLens mempty
-    <*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty
-    <*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty
-    <*> optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty
-    <*> pure NoFlag -- flibdir
-    <*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty
-    <*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty
-    <*> pure NoFlag -- includedir
-    <*> optionalFieldDef "datadir" installDirsDatadirLens mempty
-    <*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty
-    <*> optionalFieldDef "docdir" installDirsDocdirLens mempty
-    <*> pure NoFlag -- mandir
-    <*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty
-    <*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty
-    <*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty
+installDirsGrammar = do
+  prefix <- optionalFieldDef "prefix" installDirsPrefixLens mempty
+  bindir <- optionalFieldDef "bindir" installDirsBindirLens mempty
+  libdir <- optionalFieldDef "libdir" installDirsLibdirLens mempty
+  libsubdir <- optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty
+  dynlibdir <- optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty
+  bytecodelibdir <- optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty
+  let flibdir = NoFlag
+  libexecdir <- optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty
+  libexecsubdir <- optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty
+  let includedir = NoFlag
+  datadir <- optionalFieldDef "datadir" installDirsDatadirLens mempty
+  datasubdir <- optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty
+  docdir <- optionalFieldDef "docdir" installDirsDocdirLens mempty
+  let mandir = NoFlag
+  htmldir <- optionalFieldDef "htmldir" installDirsHtmldirLens mempty
+  haddockdir <- optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty
+  sysconfdir <- optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty
+  pure InstallDirs{..}
 
 -- ---------------------------------------------------------------------------
 -- Lenses

cabal-dev-scripts/src/GenSPDX.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 module Main (main) where
 
 import Control.Lens     (imap)
@@ -119,12 +121,13 @@ newtype LicenseList = LL { unLL :: [License] }
   deriving (Show)
 
 instance FromJSON License where
-    parseJSON = withObject "License" $ \obj -> License
-        <$> obj .: "licenseId"
-        <*> obj .: "name"
-        <*> obj .: "isOsiApproved"
-        <*> obj .:? "isFsfLibre" .!= False
-        <*> obj .: "isDeprecatedLicenseId"
+    parseJSON = withObject "License" $ \obj -> do
+        licenseId <- obj .: "licenseId"
+        licenseName <- obj .: "name"
+        licenseOsiApproved <- obj .: "isOsiApproved"
+        licenseFsfLibre <- obj .:? "isFsfLibre" .!= False
+        licenseDeprecated <- obj .: "isDeprecatedLicenseId"
+        pure License{..}
 
 instance FromJSON LicenseList where
     parseJSON = withObject "License list" $ \obj ->

cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- |
 -- Module      :  Distribution.Client.Reporting
@@ -117,18 +119,18 @@ fieldDescrs
      , c (List VCat (Identity PackageIdentifier) PackageIdentifier)
      )
   => g BuildReport BuildReport
-fieldDescrs =
-  BuildReport
-    <$> uniqueField "package" L.package
-    <*> uniqueField "os" L.os
-    <*> uniqueField "arch" L.arch
-    <*> uniqueField "compiler" L.compiler
-    <*> uniqueField "client" L.client
-    <*> monoidalField "flags" L.flagAssignment
-    <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
-    <*> uniqueField "install-outcome" L.installOutcome
-    <*> uniqueField "docs-outcome" L.docsOutcome
-    <*> uniqueField "tests-outcome" L.testsOutcome
+fieldDescrs = do
+  package <- uniqueField "package" L.package
+  os <- uniqueField "os" L.os
+  arch <- uniqueField "arch" L.arch
+  compiler <- uniqueField "compiler" L.compiler
+  client <- uniqueField "client" L.client
+  flagAssignment <- monoidalField "flags" L.flagAssignment
+  dependencies <- monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
+  installOutcome <- uniqueField "install-outcome" L.installOutcome
+  docsOutcome <- uniqueField "docs-outcome" L.docsOutcome
+  testsOutcome <- uniqueField "tests-outcome" L.testsOutcome
+  pure BuildReport{..}
 
 -- -----------------------------------------------------------------------------
 -- Parsing

cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Distribution.Client.CmdInstall.ClientInstallFlags
   ( InstallMethod (..)
@@ -122,15 +124,15 @@ clientInstallFlagsGrammar
      , c (Identity (Flag InstallMethod))
      )
   => g ClientInstallFlags ClientInstallFlags
-clientInstallFlagsGrammar =
-  ClientInstallFlags
-    <$> optionalFieldDef "lib" cinstInstallLibsLens mempty
-    <*> ( optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
-            <* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
-        )
-    <*> optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty
-    <*> optionalFieldDef "install-method" cinstInstallMethodLens mempty
-    <*> optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty
+clientInstallFlagsGrammar = do
+  cinstInstallLibs <- optionalFieldDef "lib" cinstInstallLibsLens mempty
+  cinstEnvironmentPath <-
+    optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
+      <* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
+  cinstOverwritePolicy <- optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty
+  cinstInstallMethod <- optionalFieldDef "install-method" cinstInstallMethodLens mempty
+  cinstInstalldir <- optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty
+  pure ClientInstallFlags{..}
 {-# SPECIALIZE clientInstallFlagsGrammar :: ParsecFieldGrammar' ClientInstallFlags #-}
 
 parsecInstallMethod :: CabalParsing m => m InstallMethod

cabal-install/src/Distribution/Client/DistDirLayout.hs

@@ -336,4 +336,4 @@ mkCabalDirLayout mstoreDir mlogDir = do
     defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir
   cabalLogsDirectory <-
     maybe defaultLogsDir pure mlogDir
-  pure $ CabalDirLayout{..}
+  pure CabalDirLayout{..}

cabal-install/src/Distribution/Client/Init/Interactive/Command.hs

@@ -1,9 +1,7 @@
+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE PatternSynonyms #-}
-
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
+{-# LANGUAGE RecordWildCards #-}
 
 -- |
 -- Module      :  Distribution.Client.Init.Command
@@ -192,19 +190,19 @@ genPkgDescription
   -> SourcePackageDb
   -> m PkgDescription
 genPkgDescription flags' srcDb = do
-  csv <- cabalVersionPrompt flags'
-  let flags = flags'{cabalVersion = Flag csv}
-  PkgDescription csv
-    <$> packageNamePrompt srcDb flags
-    <*> versionPrompt flags
-    <*> licensePrompt flags
-    <*> authorPrompt flags
-    <*> emailPrompt flags
-    <*> homepagePrompt flags
-    <*> synopsisPrompt flags
-    <*> categoryPrompt flags
-    <*> getExtraSrcFiles flags
-    <*> getExtraDocFiles flags
+  _pkgCabalVersion <- cabalVersionPrompt flags'
+  let flags = flags'{cabalVersion = Flag _pkgCabalVersion}
+  _pkgName <- packageNamePrompt srcDb flags
+  _pkgVersion <- versionPrompt flags
+  _pkgLicense <- licensePrompt flags
+  _pkgAuthor <- authorPrompt flags
+  _pkgEmail <- emailPrompt flags
+  _pkgHomePage <- homepagePrompt flags
+  _pkgSynopsis <- synopsisPrompt flags
+  _pkgCategory <- categoryPrompt flags
+  _pkgExtraSrcFiles <- getExtraSrcFiles flags
+  _pkgExtraDocFiles <- getExtraDocFiles flags
+  pure PkgDescription{..}
 
 -- | Extract flags relevant to a library target and interactively
 -- generate a 'LibTarget' object for creation. If the user specifies
@@ -215,15 +213,15 @@ genLibTarget
   => InitFlags
   -> InstalledPackageIndex
   -> m LibTarget
-genLibTarget flags pkgs =
-  LibTarget
-    <$> srcDirsPrompt flags
-    <*> languagePrompt flags "library"
-    <*> getExposedModules flags
-    <*> getOtherModules flags
-    <*> getOtherExts flags
-    <*> dependenciesPrompt pkgs flags
-    <*> getBuildTools flags
+genLibTarget flags pkgs = do
+  _libSourceDirs <- srcDirsPrompt flags
+  _libLanguage <- languagePrompt flags "library"
+  _libExposedModules <- getExposedModules flags
+  _libOtherModules <- getOtherModules flags
+  _libOtherExts <- getOtherExts flags
+  _libDependencies <- dependenciesPrompt pkgs flags
+  _libBuildTools <- getBuildTools flags
+  pure LibTarget{..}
 
 -- | Extract flags relevant to a executable target and interactively
 -- generate a 'ExeTarget' object for creation. If the user specifies
@@ -234,15 +232,15 @@ genExeTarget
   => InitFlags
   -> InstalledPackageIndex
   -> m ExeTarget
-genExeTarget flags pkgs =
-  ExeTarget
-    <$> mainFilePrompt flags
-    <*> appDirsPrompt flags
-    <*> languagePrompt flags "executable"
-    <*> getOtherModules flags
-    <*> getOtherExts flags
-    <*> dependenciesPrompt pkgs flags
-    <*> getBuildTools flags
+genExeTarget flags pkgs = do
+  _exeMainIs <- mainFilePrompt flags
+  _exeApplicationDirs <- appDirsPrompt flags
+  _exeLanguage <- languagePrompt flags "executable"
+  _exeOtherModules <- getOtherModules flags
+  _exeOtherExts <- getOtherExts flags
+  _exeDependencies <- dependenciesPrompt pkgs flags
+  _exeBuildTools <- getBuildTools flags
+  pure ExeTarget{..}
 
 -- | Extract flags relevant to a test target and interactively
 -- generate a 'TestTarget' object for creation. If the user specifies
@@ -261,16 +259,15 @@ genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go
   where
     go initialized
       | not initialized = return Nothing
-      | otherwise =
-          fmap Just $
-            TestTarget
-              <$> testMainPrompt
-              <*> testDirsPrompt flags
-              <*> languagePrompt flags "test suite"
-              <*> getOtherModules flags
-              <*> getOtherExts flags
-              <*> dependenciesPrompt pkgs flags
-              <*> getBuildTools flags
+      | otherwise = do
+          _testMainIs <- testMainPrompt
+          _testDirs <- testDirsPrompt flags
+          _testLanguage <- languagePrompt flags "test suite"
+          _testOtherModules <- getOtherModules flags
+          _testOtherExts <- getOtherExts flags
+          _testDependencies <- dependenciesPrompt pkgs flags
+          _testBuildTools <- getBuildTools flags
+          pure $ Just TestTarget{..}
 
 -- -------------------------------------------------------------------- --
 -- Prompts