Skip to content

Commit ab07653

Browse files
BodigrimBodigrim
committed
There is a better way to parse record fields (ApplicativeDo + RecordWildCards)
1 parent 996d9e0 commit ab07653

15 files changed

Lines changed: 618 additions & 630 deletions

File tree

‎Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs‎

Lines changed: 171 additions & 143 deletions
Large diffs are not rendered by default.

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

Lines changed: 17 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE OverloadedStrings #-}
23
{-# LANGUAGE RecordWildCards #-}
34

@@ -303,27 +304,26 @@ basicFieldGrammar
303304
, c (MQuoted Version)
304305
)
305306
=> g Basic Basic
306-
basicFieldGrammar =
307-
mkBasic
308-
<$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
309-
<*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion
310-
<*> optionalField "package-name" basicPkgName
311-
<*> optionalField "lib-name" basicLibName
312-
<*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
313-
where
314-
mkBasic n v pn ln lv = Basic n v pn ln' lv'
315-
where
316-
ln' = maybe LMainLibName LSubLibName ln
317-
-- Older GHCs (<8.8) always report installed libraries as private
307+
basicFieldGrammar = do
308+
_basicName <- optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
309+
_basicVersion <- optionalFieldDefAla "version" MQuoted basicVersion nullVersion
310+
_basicPkgName <- optionalField "package-name" basicPkgName
311+
_basicLibName <- maybe LMainLibName LSubLibName <$> optionalField "lib-name" basicLibName
312+
_basicLibVisibility' <- optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
313+
pure
314+
Basic
315+
{ -- Older GHCs (<8.8) always report installed libraries as private
318316
-- because their ghc-pkg builds with an older Cabal.
319317
-- So we always set LibraryVisibilityPublic for main (unnamed) libs.
320318
-- This can be removed once we stop supporting GHC<8.8, at the
321319
-- condition that we keep marking main libraries as public when
322320
-- registering them.
323-
lv' =
324-
if let MungedPackageName _ mln = n
325-
in -- We need to check both because on ghc<8.2 ln' will always
321+
_basicLibVisibility =
322+
if let MungedPackageName _ mln = _basicName
323+
in -- We need to check both because on ghc<8.2 _basicLibName will always
326324
-- be LMainLibName
327-
ln' == LMainLibName && mln == LMainLibName
325+
_basicLibName == LMainLibName && mln == LMainLibName
328326
then LibraryVisibilityPublic
329-
else lv
327+
else _basicLibVisibility'
328+
, ..
329+
}

‎Cabal/src/Distribution/Simple/InstallDirs.hs‎

Lines changed: 21 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,9 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE CApiFFI #-}
23
{-# LANGUAGE CPP #-}
34
{-# LANGUAGE DerivingVia #-}
45
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RecordWildCards #-}
57

68
-- |
79
-- Module : Distribution.Simple.InstallDirs
@@ -559,25 +561,25 @@ foreign import capi unsafe "shlobj.h SHGetFolderPathW"
559561
-- FieldGrammar
560562

561563
installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate))
562-
installDirsGrammar =
563-
InstallDirs
564-
<$> optionalFieldDef "prefix" installDirsPrefixLens mempty
565-
<*> optionalFieldDef "bindir" installDirsBindirLens mempty
566-
<*> optionalFieldDef "libdir" installDirsLibdirLens mempty
567-
<*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty
568-
<*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty
569-
<*> optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty
570-
<*> pure NoFlag -- flibdir
571-
<*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty
572-
<*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty
573-
<*> pure NoFlag -- includedir
574-
<*> optionalFieldDef "datadir" installDirsDatadirLens mempty
575-
<*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty
576-
<*> optionalFieldDef "docdir" installDirsDocdirLens mempty
577-
<*> pure NoFlag -- mandir
578-
<*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty
579-
<*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty
580-
<*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty
564+
installDirsGrammar = do
565+
prefix <- optionalFieldDef "prefix" installDirsPrefixLens mempty
566+
bindir <- optionalFieldDef "bindir" installDirsBindirLens mempty
567+
libdir <- optionalFieldDef "libdir" installDirsLibdirLens mempty
568+
libsubdir <- optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty
569+
dynlibdir <- optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty
570+
bytecodelibdir <- optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty
571+
let flibdir = NoFlag
572+
libexecdir <- optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty
573+
libexecsubdir <- optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty
574+
let includedir = NoFlag
575+
datadir <- optionalFieldDef "datadir" installDirsDatadirLens mempty
576+
datasubdir <- optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty
577+
docdir <- optionalFieldDef "docdir" installDirsDocdirLens mempty
578+
let mandir = NoFlag
579+
htmldir <- optionalFieldDef "htmldir" installDirsHtmldirLens mempty
580+
haddockdir <- optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty
581+
sysconfdir <- optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty
582+
pure InstallDirs{..}
581583

582584
-- ---------------------------------------------------------------------------
583585
-- Lenses

‎cabal-dev-scripts/src/GenSPDX.hs‎

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
24
module Main (main) where
35

46
import Control.Lens (imap)
@@ -119,12 +121,13 @@ newtype LicenseList = LL { unLL :: [License] }
119121
deriving (Show)
120122

121123
instance FromJSON License where
122-
parseJSON = withObject "License" $ \obj -> License
123-
<$> obj .: "licenseId"
124-
<*> obj .: "name"
125-
<*> obj .: "isOsiApproved"
126-
<*> obj .:? "isFsfLibre" .!= False
127-
<*> obj .: "isDeprecatedLicenseId"
124+
parseJSON = withObject "License" $ \obj -> do
125+
licenseId <- obj .: "licenseId"
126+
licenseName <- obj .: "name"
127+
licenseOsiApproved <- obj .: "isOsiApproved"
128+
licenseFsfLibre <- obj .:? "isFsfLibre" .!= False
129+
licenseDeprecated <- obj .: "isDeprecatedLicenseId"
130+
pure License{..}
128131

129132
instance FromJSON LicenseList where
130133
parseJSON = withObject "License list" $ \obj ->

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

Lines changed: 14 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
24

35
-- |
46
-- Module : Distribution.Client.Reporting
@@ -117,18 +119,18 @@ fieldDescrs
117119
, c (List VCat (Identity PackageIdentifier) PackageIdentifier)
118120
)
119121
=> g BuildReport BuildReport
120-
fieldDescrs =
121-
BuildReport
122-
<$> uniqueField "package" L.package
123-
<*> uniqueField "os" L.os
124-
<*> uniqueField "arch" L.arch
125-
<*> uniqueField "compiler" L.compiler
126-
<*> uniqueField "client" L.client
127-
<*> monoidalField "flags" L.flagAssignment
128-
<*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
129-
<*> uniqueField "install-outcome" L.installOutcome
130-
<*> uniqueField "docs-outcome" L.docsOutcome
131-
<*> uniqueField "tests-outcome" L.testsOutcome
122+
fieldDescrs = do
123+
package <- uniqueField "package" L.package
124+
os <- uniqueField "os" L.os
125+
arch <- uniqueField "arch" L.arch
126+
compiler <- uniqueField "compiler" L.compiler
127+
client <- uniqueField "client" L.client
128+
flagAssignment <- monoidalField "flags" L.flagAssignment
129+
dependencies <- monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
130+
installOutcome <- uniqueField "install-outcome" L.installOutcome
131+
docsOutcome <- uniqueField "docs-outcome" L.docsOutcome
132+
testsOutcome <- uniqueField "tests-outcome" L.testsOutcome
133+
pure BuildReport{..}
132134

133135
-- -----------------------------------------------------------------------------
134136
-- Parsing

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

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE DerivingVia #-}
23
{-# LANGUAGE OverloadedStrings #-}
34
{-# LANGUAGE PatternSynonyms #-}
5+
{-# LANGUAGE RecordWildCards #-}
46

57
module Distribution.Client.CmdInstall.ClientInstallFlags
68
( InstallMethod (..)
@@ -122,15 +124,15 @@ clientInstallFlagsGrammar
122124
, c (Identity (Flag InstallMethod))
123125
)
124126
=> g ClientInstallFlags ClientInstallFlags
125-
clientInstallFlagsGrammar =
126-
ClientInstallFlags
127-
<$> optionalFieldDef "lib" cinstInstallLibsLens mempty
128-
<*> ( optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
129-
<* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
130-
)
131-
<*> optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty
132-
<*> optionalFieldDef "install-method" cinstInstallMethodLens mempty
133-
<*> optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty
127+
clientInstallFlagsGrammar = do
128+
cinstInstallLibs <- optionalFieldDef "lib" cinstInstallLibsLens mempty
129+
cinstEnvironmentPath <-
130+
optionalFieldDefAla "package-env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
131+
<* optionalFieldDefAla "env" (alaFlag FilePathNT) cinstEnvironmentPathLens mempty
132+
cinstOverwritePolicy <- optionalFieldDef "overwrite-policy" cinstOverwritePolicyLens mempty
133+
cinstInstallMethod <- optionalFieldDef "install-method" cinstInstallMethodLens mempty
134+
cinstInstalldir <- optionalFieldDefAla "installdir" (alaFlag FilePathNT) cinstInstalldirLens mempty
135+
pure ClientInstallFlags{..}
134136
{-# SPECIALIZE clientInstallFlagsGrammar :: ParsecFieldGrammar' ClientInstallFlags #-}
135137

136138
parsecInstallMethod :: CabalParsing m => m InstallMethod

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -336,4 +336,4 @@ mkCabalDirLayout mstoreDir mlogDir = do
336336
defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir
337337
cabalLogsDirectory <-
338338
maybe defaultLogsDir pure mlogDir
339-
pure $ CabalDirLayout{..}
339+
pure CabalDirLayout{..}

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

Lines changed: 42 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,7 @@
1+
{-# LANGUAGE ApplicativeDo #-}
12
{-# LANGUAGE MultiWayIf #-}
23
{-# LANGUAGE PatternSynonyms #-}
3-
4-
-----------------------------------------------------------------------------
5-
6-
-----------------------------------------------------------------------------
4+
{-# LANGUAGE RecordWildCards #-}
75

86
-- |
97
-- Module : Distribution.Client.Init.Command
@@ -192,19 +190,19 @@ genPkgDescription
192190
-> SourcePackageDb
193191
-> m PkgDescription
194192
genPkgDescription flags' srcDb = do
195-
csv <- cabalVersionPrompt flags'
196-
let flags = flags'{cabalVersion = Flag csv}
197-
PkgDescription csv
198-
<$> packageNamePrompt srcDb flags
199-
<*> versionPrompt flags
200-
<*> licensePrompt flags
201-
<*> authorPrompt flags
202-
<*> emailPrompt flags
203-
<*> homepagePrompt flags
204-
<*> synopsisPrompt flags
205-
<*> categoryPrompt flags
206-
<*> getExtraSrcFiles flags
207-
<*> getExtraDocFiles flags
193+
_pkgCabalVersion <- cabalVersionPrompt flags'
194+
let flags = flags'{cabalVersion = Flag _pkgCabalVersion}
195+
_pkgName <- packageNamePrompt srcDb flags
196+
_pkgVersion <- versionPrompt flags
197+
_pkgLicense <- licensePrompt flags
198+
_pkgAuthor <- authorPrompt flags
199+
_pkgEmail <- emailPrompt flags
200+
_pkgHomePage <- homepagePrompt flags
201+
_pkgSynopsis <- synopsisPrompt flags
202+
_pkgCategory <- categoryPrompt flags
203+
_pkgExtraSrcFiles <- getExtraSrcFiles flags
204+
_pkgExtraDocFiles <- getExtraDocFiles flags
205+
pure PkgDescription{..}
208206

209207
-- | Extract flags relevant to a library target and interactively
210208
-- generate a 'LibTarget' object for creation. If the user specifies
@@ -215,15 +213,15 @@ genLibTarget
215213
=> InitFlags
216214
-> InstalledPackageIndex
217215
-> m LibTarget
218-
genLibTarget flags pkgs =
219-
LibTarget
220-
<$> srcDirsPrompt flags
221-
<*> languagePrompt flags "library"
222-
<*> getExposedModules flags
223-
<*> getOtherModules flags
224-
<*> getOtherExts flags
225-
<*> dependenciesPrompt pkgs flags
226-
<*> getBuildTools flags
216+
genLibTarget flags pkgs = do
217+
_libSourceDirs <- srcDirsPrompt flags
218+
_libLanguage <- languagePrompt flags "library"
219+
_libExposedModules <- getExposedModules flags
220+
_libOtherModules <- getOtherModules flags
221+
_libOtherExts <- getOtherExts flags
222+
_libDependencies <- dependenciesPrompt pkgs flags
223+
_libBuildTools <- getBuildTools flags
224+
pure LibTarget{..}
227225

228226
-- | Extract flags relevant to a executable target and interactively
229227
-- generate a 'ExeTarget' object for creation. If the user specifies
@@ -234,15 +232,15 @@ genExeTarget
234232
=> InitFlags
235233
-> InstalledPackageIndex
236234
-> m ExeTarget
237-
genExeTarget flags pkgs =
238-
ExeTarget
239-
<$> mainFilePrompt flags
240-
<*> appDirsPrompt flags
241-
<*> languagePrompt flags "executable"
242-
<*> getOtherModules flags
243-
<*> getOtherExts flags
244-
<*> dependenciesPrompt pkgs flags
245-
<*> getBuildTools flags
235+
genExeTarget flags pkgs = do
236+
_exeMainIs <- mainFilePrompt flags
237+
_exeApplicationDirs <- appDirsPrompt flags
238+
_exeLanguage <- languagePrompt flags "executable"
239+
_exeOtherModules <- getOtherModules flags
240+
_exeOtherExts <- getOtherExts flags
241+
_exeDependencies <- dependenciesPrompt pkgs flags
242+
_exeBuildTools <- getBuildTools flags
243+
pure ExeTarget{..}
246244

247245
-- | Extract flags relevant to a test target and interactively
248246
-- generate a 'TestTarget' object for creation. If the user specifies
@@ -261,16 +259,15 @@ genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go
261259
where
262260
go initialized
263261
| not initialized = return Nothing
264-
| otherwise =
265-
fmap Just $
266-
TestTarget
267-
<$> testMainPrompt
268-
<*> testDirsPrompt flags
269-
<*> languagePrompt flags "test suite"
270-
<*> getOtherModules flags
271-
<*> getOtherExts flags
272-
<*> dependenciesPrompt pkgs flags
273-
<*> getBuildTools flags
262+
| otherwise = do
263+
_testMainIs <- testMainPrompt
264+
_testDirs <- testDirsPrompt flags
265+
_testLanguage <- languagePrompt flags "test suite"
266+
_testOtherModules <- getOtherModules flags
267+
_testOtherExts <- getOtherExts flags
268+
_testDependencies <- dependenciesPrompt pkgs flags
269+
_testBuildTools <- getBuildTools flags
270+
pure $ Just TestTarget{..}
274271

275272
-- -------------------------------------------------------------------- --
276273
-- Prompts

0 commit comments

Comments
 (0)