Commit 73dd1c26 authored by Daniel Trstenjak's avatar Daniel Trstenjak

More diff friendly pretty printing of cabal files

Now the 'fieldGet' function of 'FieldDescr' does the
whole pretty printing of the field. Previously only the
values have been pretty printed by 'fieldGet' and the
name of the field with the colon have been printed
in the 'PrettyPrint' module.

But this separation made it more difficult to handle the
pretty printing of fields differently, because some fields
should be just printed in one lines and others - having several
values - should be printed nested with each value on a new line.

This difference in the printing of the fields is now handled by
the 'FieldDescr' constructor functions in 'ParseUtils'.

Now the 'listField' and 'commaListField' functions create 'FieldDescr'
that nest their values and all other functions create one line
for the whole field.
parent 379652d6
......@@ -151,6 +151,7 @@ library
Distribution.PackageDescription.Configuration
Distribution.PackageDescription.Parse
Distribution.PackageDescription.PrettyPrint
Distribution.PackageDescription.PrettyPrintIndent
Distribution.PackageDescription.Utils
Distribution.ParseUtils
Distribution.ReadE
......
......@@ -135,7 +135,7 @@ pkgDescrFieldDescrs =
[x] -> x
_ -> "")
(\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})
, listField "license-files"
, spaceListField "license-files"
showFilePath parseFilePathQ
(\pkg -> case licenseFiles pkg of
[_] -> []
......@@ -165,7 +165,7 @@ pkgDescrFieldDescrs =
, simpleField "synopsis"
showFreeText parseFreeText
synopsis (\val pkg -> pkg{synopsis=val})
, simpleField "description"
, simpleNestedField "description"
showFreeText parseFreeText
description (\val pkg -> pkg{description=val})
, simpleField "category"
......@@ -426,7 +426,7 @@ binfoFieldDescrs =
, commaListField "pkgconfig-depends"
disp parsePkgconfigDependency
pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})
, listField "frameworks"
, spaceListField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
, listField "c-sources"
......@@ -436,7 +436,7 @@ binfoFieldDescrs =
, simpleField "default-language"
(maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
, listField "other-languages"
, spaceListField "other-languages"
disp parseLanguageQ
otherLanguages (\langs binfo -> binfo{otherLanguages=langs})
, listField "default-extensions"
......@@ -464,16 +464,16 @@ binfoFieldDescrs =
, listField "include-dirs"
showFilePath parseFilePathQ
includeDirs (\paths binfo -> binfo{includeDirs=paths})
, listField "hs-source-dirs"
, spaceListField "hs-source-dirs"
showFilePath parseFilePathQ
hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
, listField "other-modules"
disp parseModuleNameQ
otherModules (\val binfo -> binfo{otherModules=val})
, listField "ghc-prof-options"
, spaceListField "ghc-prof-options"
text parseTokenQ
ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})
, listField "ghc-shared-options"
, spaceListField "ghc-shared-options"
text parseTokenQ
ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})
, optsField "ghc-options" GHC
......
......@@ -56,7 +56,7 @@ import Distribution.PackageDescription
Flag(..), PackageDescription(..),
GenericPackageDescription(..))
import Text.PrettyPrint
(hsep, comma, punctuate, fsep, parens, char, nest, empty,
(hsep, comma, punctuate, parens, char, nest, empty,
isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
import Distribution.Simple.Utils (writeUTF8File)
import Distribution.ParseUtils (showFreeText, FieldDescr(..))
......@@ -64,11 +64,9 @@ import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDesc
sourceRepoFieldDescrs)
import Distribution.Package (Dependency(..))
import Distribution.Text (Text(..))
import Distribution.PackageDescription.PrettyPrintIndent (indentWith)
import Data.Maybe (isJust, fromJust, isNothing)
indentWith :: Int
indentWith = 4
-- | Recompile with false for regression testing
simplifiedPrinting :: Bool
simplifiedPrinting = False
......@@ -108,18 +106,14 @@ ppSourceRepo repo =
ppFields :: [FieldDescr a] -> a -> Doc
ppFields fields x =
vcat [ ppField name (getter x)
| FieldDescr name getter _ <- fields]
ppField :: String -> Doc -> Doc
ppField name fielddoc | isEmpty fielddoc = empty
| otherwise = text name <> colon <+> fielddoc
vcat [ (getter x) | FieldDescr name getter _ <- fields ]
ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
ppDiffFields fields x y =
vcat [ ppField name (getter x)
| FieldDescr name getter _ <- fields,
render (getter x) /= render (getter y)]
vcat [ (getter x)
| FieldDescr name getter _ <- fields
, render (getter x) /= render (getter y)
]
ppCustomFields :: [(String,String)] -> Doc
ppCustomFields flds = vcat [ppCustomField f | f <- flds]
......@@ -262,7 +256,7 @@ ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
ppDeps :: [Dependency] -> Doc
ppDeps [] = empty
ppDeps deps =
text "build-depends:" <+> fsep (punctuate comma (map disp deps))
text "build-depends:" $+$ nest indentWith (vcat (punctuate comma (map disp deps)))
emptyLine :: Doc -> Doc
emptyLine d = text " " $+$ d
......
module Distribution.PackageDescription.PrettyPrintIndent
( indentWith
) where
-- | the indentation used for pretty printing
indentWith :: Int
indentWith = 4
......@@ -52,7 +52,7 @@ module Distribution.ParseUtils (
LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,
Field(..), fName, lineNo,
FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
FieldDescr(..), ppFields, readFields, readFieldsFlat,
showFields, showSingleNamedField, showSimpleSingleNamedField,
parseFields, parseFieldsFlat,
parseFilePathQ, parseTokenQ, parseTokenQ',
......@@ -61,7 +61,7 @@ module Distribution.ParseUtils (
parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
field, simpleField, listField, spaceListField, commaListField,
field, simpleField, simpleNestedField, listField, spaceListField, commaListField,
optsField, liftField, boolField, parseQuoted,
UnrecFieldParser, warnUnrec, ignoreUnrec,
......@@ -75,6 +75,7 @@ import Distribution.Package ( PackageName(..), Dependency(..) )
import Distribution.ModuleName (ModuleName)
import Distribution.Compat.ReadP as ReadP hiding (get)
import Distribution.ReadE
import Distribution.PackageDescription.PrettyPrintIndent (indentWith)
import Distribution.Text
( Text(..) )
import Distribution.Simple.Utils
......@@ -215,38 +216,46 @@ liftField get set (FieldDescr name showF parseF)
simpleField :: String -> (a -> Doc) -> ReadP a a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleField name showF readF get set
= liftField get set $ field name showF readF
= liftField get set $ field name (showField name showF) readF
simpleNestedField :: String -> (a -> Doc) -> ReadP a a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleNestedField name showF readF get set
= liftField get set $ field name (showNestedField name showF) readF
commaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField name showF readF get set =
liftField get set' $
field name (fsep . punctuate comma . map showF) (parseCommaList readF)
field name (showNestedField name showF') (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = vcat . punctuate comma . map showF
spaceListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
spaceListField name showF readF get set =
liftField get set' $
field name (fsep . map showF) (parseSpaceList readF)
field name (showField name showF') (parseSpaceList readF)
where
set' xs b = set (get b ++ xs) b
showF' = fsep . map showF
listField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField name showF readF get set =
liftField get set' $
field name (fsep . map showF) (parseOptCommaList readF)
field name (showNestedField name showF') (parseOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = vcat . map showF
optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])])
-> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
optsField name flavor get set =
liftField (fromMaybe [] . lookup flavor . get)
(\opts b -> set (reorder (update flavor opts (get b))) b) $
field name (hsep . map text)
field name (showField name showF)
(sepBy parseTokenQ' (munch1 isSpace))
where
update _ opts l | all null opts = l --empty opts as if no opts
......@@ -255,12 +264,13 @@ optsField name flavor get set =
| f == f' = (f, opts' ++ opts) : rest
| otherwise = (f',opts') : update f opts rest
reorder = sortBy (comparing fst)
showF = hsep . map text
-- TODO: this is a bit smelly hack. It's because we want to parse bool fields
-- liberally but not accept new parses. We cannot do that with ReadP
-- because it does not support warnings. We need a new parser framework!
boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
boolField name get set = liftField get set (FieldDescr name showF readF)
boolField name get set = liftField get set (FieldDescr name (showField name showF) readF)
where
showF = text . show
readF line str _
......@@ -275,11 +285,23 @@ boolField name get set = liftField get set (FieldDescr name showF readF)
"The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
ppFields :: [FieldDescr a] -> a -> Doc
ppFields fields x = vcat [ ppField name (getter x)
| FieldDescr name getter _ <- fields]
ppFields fields x = vcat [ getter x | FieldDescr _ getter _ <- fields]
showField :: String -> (a -> Doc) -> a -> Doc
showField name showF a =
if isEmpty shown
then empty
else text name <> colon <+> shown
where
shown = showF a
ppField :: String -> Doc -> Doc
ppField name fielddoc = text name <> colon <+> fielddoc
showNestedField :: String -> (a -> Doc) -> a -> Doc
showNestedField name showF as =
if isEmpty shown
then empty
else text name <> colon $+$ nest indentWith shown
where
shown = showF as
showFields :: [FieldDescr a] -> a -> String
showFields fields = render . ($+$ text "") . ppFields fields
......@@ -288,7 +310,7 @@ showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
showSingleNamedField fields f =
case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
[] -> Nothing
(get:_) -> Just (render . ppField f . get)
(get:_) -> Just (render . get)
showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
showSimpleSingleNamedField fields f =
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment