Commit fdf8afce authored by Daniel Trstenjak's avatar Daniel Trstenjak Committed by tibbe

Fixed pretty printing of fields

The list constructors 'nestedListField' and 'nestedCommaListField'
have been added and are now used for fields that should be pretty
printed with nesting.
parent 8024d3e3
......@@ -118,7 +118,7 @@ pkgDescrFieldDescrs =
, simpleField "maintainer"
showFreeText parseFreeText
maintainer (\val pkg -> pkg{maintainer=val})
, commaListField "build-depends"
, nestedCommaListField "build-depends"
disp parse
buildDepends (\xs pkg -> pkg{buildDepends=xs})
, simpleField "stability"
......@@ -136,7 +136,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"
......@@ -148,19 +148,19 @@ pkgDescrFieldDescrs =
, listField "tested-with"
showTestedWith parseTestedWithQ
testedWith (\val pkg -> pkg{testedWith=val})
, listField "data-files"
, nestedListField "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"
, nestedListField "extra-source-files"
showFilePath parseFilePathQ
extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
, listField "extra-tmp-files"
, nestedListField "extra-tmp-files"
showFilePath parseFilePathQ
extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
, listField "extra-doc-files"
, nestedListField "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
[ nestedListField "exposed-modules" disp parseModuleNameQ
exposedModules (\mods lib -> lib{exposedModules=mods})
, boolField "exposed"
......@@ -400,51 +400,51 @@ binfoFieldDescrs =
, listField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
, listField "c-sources"
, nestedListField "c-sources"
showFilePath parseFilePathQ
cSources (\paths binfo -> binfo{cSources=paths})
, simpleField "default-language"
(maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
, listField "other-languages"
, listField "other-languages"
disp parseLanguageQ
otherLanguages (\langs binfo -> binfo{otherLanguages=langs})
, listField "default-extensions"
, listField "default-extensions"
disp parseExtensionQ
defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts})
, listField "other-extensions"
, listField "other-extensions"
disp parseExtensionQ
otherExtensions (\exts binfo -> binfo{otherExtensions=exts})
, listField "extensions"
, listField "extensions"
disp parseExtensionQ
oldExtensions (\exts binfo -> binfo{oldExtensions=exts})
, listField "extra-libraries"
, nestedListField "extra-libraries"
showToken parseTokenQ
extraLibs (\xs binfo -> binfo{extraLibs=xs})
, listField "extra-lib-dirs"
showFilePath parseFilePathQ
extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
, listField "includes"
, nestedListField "includes"
showFilePath parseFilePathQ
includes (\paths binfo -> binfo{includes=paths})
, listField "install-includes"
, nestedListField "install-includes"
showFilePath parseFilePathQ
installIncludes (\paths binfo -> binfo{installIncludes=paths})
, listField "include-dirs"
showFilePath parseFilePathQ
includeDirs (\paths binfo -> binfo{includeDirs=paths})
, listField "hs-source-dirs"
, listField "hs-source-dirs"
showFilePath parseFilePathQ
hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
, listField "other-modules"
, nestedListField "other-modules"
disp parseModuleNameQ
otherModules (\val binfo -> binfo{otherModules=val})
, listField "ghc-prof-options"
, listField "ghc-prof-options"
text parseTokenQ
ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})
, listField "ghc-shared-options"
, listField "ghc-shared-options"
text parseTokenQ
ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})
, optsField "ghc-options" GHC
......
......@@ -27,7 +27,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(..))
......@@ -79,18 +79,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 _ 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 _ getter _ <- fields
, render (getter x) /= render (getter y)
]
ppCustomFields :: [(String,String)] -> Doc
ppCustomFields flds = vcat [ppCustomField f | f <- flds]
......@@ -233,7 +229,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
......
......@@ -23,7 +23,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',
......@@ -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, simpleNestedField, listField, nestedListField,
spaceListField, commaListField, nestedCommaListField, commaNewLineListField,
optsField, liftField, boolField, parseQuoted, indentWith,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -186,46 +187,72 @@ 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
commaListField' :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField' separator name showF readF get set =
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 (separator . punctuate comma . map showF) (parseCommaList readF)
field name (showField name showF') (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = fsep . punctuate comma . map showF
commaListField :: String -> (a -> Doc) -> ReadP [a] a
nestedCommaListField' :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
nestedCommaListField' separator name showF readF get set =
liftField get set' $
field name (showNestedField name showF') (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = separator . punctuate comma . map showF
nestedCommaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField = commaListField' fsep
nestedCommaListField = nestedCommaListField' vcat
commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaNewLineListField = commaListField' sep
commaNewLineListField = nestedCommaListField' 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 (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
-> (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 (showField name showF') (parseOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = fsep . map showF
nestedListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
nestedListField name showF readF get set =
liftField get set' $
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
......@@ -234,12 +261,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 _
......@@ -254,11 +282,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
......@@ -267,7 +307,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 =
......@@ -718,3 +758,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