Skip to content

Use PrettyField to format cabal file in cabal init #6718

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 4 commits into from
Closed

Use PrettyField to format cabal file in cabal init #6718

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
130ecf8
Replace hand-formatted generateCabalFile code with PrettyField.
m-renaud Apr 6, 2020
346e3e5
Add fieldPAla to factor out newtype wrapper logic.
m-renaud May 4, 2020
e7555b9
Add PrettyField line postprocessing.
m-renaud May 4, 2020
77b8a62
Explicitly type prependPrefix.
m-renaud May 6, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
32 changes: 23 additions & 9 deletions Cabal/Distribution/Fields/Pretty.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,11 +45,21 @@ data PrettyField ann
-- between comment lines.
--
showFields :: (ann -> [String]) -> [PrettyField ann] -> String
showFields rann = showFields' rann 4
showFields rann = showFields' rann (const id) 4

-- | 'showFields' with user specified indentation.
showFields' :: (ann -> [String]) -> Int -> [PrettyField ann] -> String
showFields' rann n = unlines . renderFields (Opts rann indent) where
showFields'
:: (ann -> [String])
-- ^ Convert an annotation to lined to preceed the field or section.
-> (ann -> [String] -> [String])
-- ^ Post-process non-annotation produced lines.
-> Int
-- ^ Indentation level.
-> [PrettyField ann]
-- ^ Fields/sections to show.
-> String
showFields' rann post n = unlines . renderFields (Opts rann indent post)
where
-- few hardcoded, "unrolled" variants.
indent | n == 4 = indent4
| n == 2 = indent2
Expand All @@ -63,7 +73,11 @@ showFields' rann n = unlines . renderFields (Opts rann indent) where
indent2 [] = []
indent2 xs = ' ' : ' ' : xs

data Opts ann = Opts (ann -> [String]) (String -> String)
data Opts ann = Opts
{ _optAnnotation ::(ann -> [String])
, _optIndent ::(String -> String)
, _optPostprocess :: ann -> [String] -> [String]
}

renderFields :: Opts ann -> [PrettyField ann] -> [String]
renderFields opts fields = flattenBlocks $ map (renderField opts len) fields
Expand Down Expand Up @@ -97,8 +111,8 @@ flattenBlocks = go0 where
| otherwise = id

renderField :: Opts ann -> Int -> PrettyField ann -> Block
renderField (Opts rann indent) fw (PrettyField ann name doc) =
Block before after $ comments ++ lines'
renderField (Opts rann indent post) fw (PrettyField ann name doc) =
Block before after $ comments ++ post ann lines'
where
comments = rann ann
before = if null comments then NoMargin else Margin
Expand All @@ -115,10 +129,10 @@ renderField (Opts rann indent) fw (PrettyField ann name doc) =
narrowStyle :: PP.Style
narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw }

renderField opts@(Opts rann indent) _ (PrettySection ann name args fields) = Block Margin Margin $
renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $
rann ann
++
[ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
++
post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ]
++
(map indent $ renderFields opts fields)

Expand Down
49 changes: 42 additions & 7 deletions Cabal/Distribution/PackageDescription/FieldGrammar.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,14 @@ module Distribution.PackageDescription.FieldGrammar (
benchmarkFieldGrammar,
validateBenchmark,
unvalidateBenchmark,
-- * Field grammars
formatDependencyList,
formatExposedModules,
formatExtraSourceFiles,
formatHsSourceDirs,
formatMixinList,
formatOtherExtensions,
formatOtherModules,
-- ** Lenses
benchmarkStanzaBenchmarkType,
benchmarkStanzaMainIs,
Expand All @@ -41,6 +49,7 @@ module Distribution.PackageDescription.FieldGrammar (

import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Language.Haskell.Extension
import Prelude ()

import Distribution.CabalSpecVersion
Expand All @@ -57,6 +66,7 @@ import Distribution.Types.ExecutableScope
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibType
import Distribution.Types.LibraryVisibility
import Distribution.Types.Mixin
import Distribution.Types.UnqualComponentName

import qualified Distribution.SPDX as SPDX
Expand Down Expand Up @@ -100,7 +110,7 @@ packageDescriptionFieldGrammar = PackageDescription
-- * Files
<*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles
<*> optionalFieldDefAla "data-dir" FilePathNT L.dataDir ""
<*> monoidalFieldAla "extra-source-files" (alaList' VCat FilePathNT) L.extraSrcFiles
<*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles
<*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles
<*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles
where
Expand All @@ -125,7 +135,7 @@ libraryFieldGrammar
=> LibraryName
-> g Library Library
libraryFieldGrammar n = Library n
<$> monoidalFieldAla "exposed-modules" (alaList' VCat MQuoted) L.exposedModules
<$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules
<*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules
<*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures
^^^ availableSince CabalSpecV2_0 []
Expand Down Expand Up @@ -408,14 +418,14 @@ buildInfoFieldGrammar = BuildInfo
^^^ availableSince CabalSpecV2_2 []
<*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources
<*> hsSourceDirsGrammar
<*> monoidalFieldAla "other-modules" (alaList' VCat MQuoted) L.otherModules
<*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules
<*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules
^^^ availableSince CabalSpecV2_2 []
<*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules
<*> optionalFieldAla "default-language" MQuoted L.defaultLanguage
<*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages
<*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions
<*> monoidalFieldAla "other-extensions" (alaList' FSep MQuoted) L.otherExtensions
<*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions
<*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions
^^^ deprecatedSince CabalSpecV1_12
"Please use 'default-extensions' or 'other-extensions' fields."
Expand All @@ -438,8 +448,8 @@ buildInfoFieldGrammar = BuildInfo
<*> sharedOptionsFieldGrammar
<*> pure mempty -- static-options ???
<*> prefixedFields "x-" L.customFieldsBI
<*> monoidalFieldAla "build-depends" (alaList CommaVCat) L.targetBuildDepends
<*> monoidalFieldAla "mixins" (alaList CommaVCat) L.mixins
<*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
<*> monoidalFieldAla "mixins" formatMixinList L.mixins
^^^ availableSince CabalSpecV2_0 []
{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}
{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-}
Expand All @@ -448,7 +458,7 @@ hsSourceDirsGrammar
:: (FieldGrammar g, Applicative (g BuildInfo))
=> g BuildInfo [FilePath]
hsSourceDirsGrammar = (++)
<$> monoidalFieldAla "hs-source-dirs" (alaList' FSep FilePathNT) L.hsSourceDirs
<$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs
<*> monoidalFieldAla "hs-source-dir" (alaList' FSep FilePathNT) wrongLens
--- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44
^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'"
Expand Down Expand Up @@ -542,3 +552,28 @@ setupBInfoFieldGrammar def = flip SetupBuildInfo def
<$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-}
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool ->PrettyFieldGrammar' SetupBuildInfo #-}

-------------------------------------------------------------------------------
-- Define how field values should be formatted for 'pretty'.
-------------------------------------------------------------------------------

formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency
formatDependencyList = alaList CommaVCat

formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin
formatMixinList = alaList CommaVCat

formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath
formatExtraSourceFiles = alaList' VCat FilePathNT

formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName
formatExposedModules = alaList' VCat MQuoted

formatHsSourceDirs :: [FilePath] -> List FSep FilePathNT FilePath
formatHsSourceDirs = alaList' FSep FilePathNT

formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension
formatOtherExtensions = alaList' FSep MQuoted

formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName
formatOtherModules = alaList' VCat MQuoted
8 changes: 3 additions & 5 deletions cabal-install/Distribution/Client/Init/Command.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -67,7 +67,7 @@ import Distribution.Client.Init.Prompt
( prompt, promptYesNo, promptStr, promptList, maybePrompt
, promptListOptional )
import Distribution.Client.Init.Utils
( eligibleForTestSuite, message )
( eligibleForTestSuite, message )
import Distribution.Client.Init.Types
( InitFlags(..), PackageType(..), Category(..)
, displayPackageType )
Expand All @@ -76,6 +76,8 @@ import Distribution.Client.Init.Heuristics
SourceFileEntry(..),
scanForModules, neededBuildPrograms )

import Distribution.Simple.Flag
( maybeToFlag )
import Distribution.Simple.Setup
( Flag(..), flagToMaybe )
import Distribution.Simple.Configure
Expand Down Expand Up @@ -169,10 +171,6 @@ f ?>> g = do
then return ma
else g

-- | Witness the isomorphism between Maybe and Flag.
maybeToFlag :: Maybe a -> Flag a
maybeToFlag = maybe NoFlag Flag

-- | Ask if a simple project with sensible defaults should be created.
getSimpleProject :: InitFlags -> IO InitFlags
getSimpleProject flags = do
Expand Down
Loading