Commit 1ecd69c7 authored by Daniel Trstenjak's avatar Daniel Trstenjak Committed by tibbe

More diff friendly pretty printing of cabal files

Added the new field constructor functions 'listFieldWithSep'
and 'commaListFieldWithSep' to be able to define pretty printing
for fields, where each value of the field is positioned on a new line.

Which fields are nested is currently hard coded in the 'ppField' function.

(cherry picked from commit e8d5ea25)
parent fa101c5c
......@@ -118,7 +118,7 @@ pkgDescrFieldDescrs =
, simpleField "maintainer"
showFreeText parseFreeText
maintainer (\val pkg -> pkg{maintainer=val})
, commaListField "build-depends"
, commaListFieldWithSep vcat "build-depends"
disp parse
buildDepends (\xs pkg -> pkg{buildDepends=xs})
, simpleField "stability"
......@@ -148,19 +148,19 @@ pkgDescrFieldDescrs =
, listField "tested-with"
showTestedWith parseTestedWithQ
testedWith (\val pkg -> pkg{testedWith=val})
, listField "data-files"
, listFieldWithSep vcat "data-files"
showFilePath parseFilePathQ
dataFiles (\val pkg -> pkg{dataFiles=val})
, simpleField "data-dir"
showFilePath parseFilePathQ
dataDir (\val pkg -> pkg{dataDir=val})
, listField "extra-source-files"
, listFieldWithSep vcat "extra-source-files"
showFilePath parseFilePathQ
extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
, listField "extra-tmp-files"
, listFieldWithSep vcat "extra-tmp-files"
showFilePath parseFilePathQ
extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
, listField "extra-doc-files"
, listFieldWithSep vcat "extra-doc-files"
showFilePath parseFilePathQ
extraDocFiles (\val pkg -> pkg{extraDocFiles=val})
]
......@@ -178,7 +178,7 @@ storeXFieldsPD _ _ = Nothing
libFieldDescrs :: [FieldDescr Library]
libFieldDescrs =
[ listField "exposed-modules" disp parseModuleNameQ
[ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ
exposedModules (\mods lib -> lib{exposedModules=mods})
, boolField "exposed"
......@@ -400,7 +400,7 @@ binfoFieldDescrs =
, listField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
, listField "c-sources"
, listFieldWithSep vcat "c-sources"
showFilePath parseFilePathQ
cSources (\paths binfo -> binfo{cSources=paths})
......@@ -420,16 +420,16 @@ binfoFieldDescrs =
disp parseExtensionQ
oldExtensions (\exts binfo -> binfo{oldExtensions=exts})
, listField "extra-libraries"
, listFieldWithSep vcat "extra-libraries"
showToken parseTokenQ
extraLibs (\xs binfo -> binfo{extraLibs=xs})
, listField "extra-lib-dirs"
showFilePath parseFilePathQ
extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
, listField "includes"
, listFieldWithSep vcat "includes"
showFilePath parseFilePathQ
includes (\paths binfo -> binfo{includes=paths})
, listField "install-includes"
, listFieldWithSep vcat "install-includes"
showFilePath parseFilePathQ
installIncludes (\paths binfo -> binfo{installIncludes=paths})
, listField "include-dirs"
......@@ -438,7 +438,7 @@ binfoFieldDescrs =
, listField "hs-source-dirs"
showFilePath parseFilePathQ
hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
, listField "other-modules"
, listFieldWithSep vcat "other-modules"
disp parseModuleNameQ
otherModules (\val binfo -> binfo{otherModules=val})
, listField "ghc-prof-options"
......
......@@ -27,19 +27,16 @@ 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(..))
import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)
import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
sourceRepoFieldDescrs)
import Distribution.Package (Dependency(..))
import Distribution.Text (Text(..))
import Data.Maybe (isJust, fromJust, isNothing)
indentWith :: Int
indentWith = 4
-- | Recompile with false for regression testing
simplifiedPrinting :: Bool
simplifiedPrinting = False
......@@ -77,20 +74,12 @@ ppSourceRepo repo =
where
sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
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
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 [ ppField name (getter x)
| FieldDescr name getter _ <- fields
, render (getter x) /= render (getter y)
]
ppCustomFields :: [(String,String)] -> Doc
ppCustomFields flds = vcat [ppCustomField f | f <- flds]
......@@ -233,7 +222,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
......
......@@ -32,8 +32,9 @@ module Distribution.ParseUtils (
parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
field, simpleField, listField, spaceListField, commaListField,
commaNewLineListField, optsField, liftField, boolField, parseQuoted,
field, simpleField, listField, listFieldWithSep, spaceListField,
commaListField, commaListFieldWithSep, commaNewLineListField,
optsField, liftField, boolField, parseQuoted, indentWith,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -65,7 +66,8 @@ import Data.List (sortBy)
-- -----------------------------------------------------------------------------
type LineNo = Int
type LineNo = Int
type Separator = ([Doc] -> Doc)
data PError = AmbiguousParse String LineNo
| NoParse String LineNo
......@@ -188,45 +190,51 @@ simpleField :: String -> (a -> Doc) -> ReadP a a
simpleField name showF readF get set
= liftField get set $ field name showF readF
commaListField' :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField' separator name showF readF get set =
liftField get set' $
field name (separator . punctuate comma . map showF) (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListFieldWithSep separator name showF readF get set =
liftField get set' $
field name showF' (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = separator . punctuate comma . map showF
commaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField = commaListField' fsep
commaListField = commaListFieldWithSep fsep
commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaNewLineListField = commaListField' sep
commaNewLineListField = commaListFieldWithSep sep
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 showF' (parseSpaceList readF)
where
set' xs b = set (get b ++ xs) b
showF' = fsep . map showF
listField :: String -> (a -> Doc) -> ReadP [a] a
listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField name showF readF get set =
listFieldWithSep separator name showF readF get set =
liftField get set' $
field name (fsep . map showF) (parseOptCommaList readF)
field name showF' (parseOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = separator . map showF
listField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField = listFieldWithSep fsep
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)
(sepBy parseTokenQ' (munch1 isSpace))
field name showF (sepBy parseTokenQ' (munch1 isSpace))
where
update _ opts l | all null opts = l --empty opts as if no opts
update f opts [] = [(f,opts)]
......@@ -234,6 +242,7 @@ 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
......@@ -254,11 +263,28 @@ 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 [ ppField name (getter x) | FieldDescr name getter _ <- fields ]
ppField :: String -> Doc -> Doc
ppField name fielddoc = text name <> colon <+> fielddoc
ppField name fielddoc
| isEmpty fielddoc = empty
| name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc
| otherwise = text name <> colon <+> fielddoc
where
nestedFields =
[ "description"
, "build-depends"
, "data-files"
, "extra-source-files"
, "extra-tmp-files"
, "exposed-modules"
, "c-sources"
, "extra-libraries"
, "includes"
, "install-includes"
, "other-modules"
]
showFields :: [FieldDescr a] -> a -> String
showFields fields = render . ($+$ text "") . ppFields fields
......@@ -718,3 +744,7 @@ lines_ s = let (l, s') = break (== '\n') s
in l : case s' of
[] -> []
(_:s'') -> lines_ s''
-- | the indentation used for pretty printing
indentWith :: Int
indentWith = 4
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