Commit 285a7b3c authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Revert "Fixed pretty printing of fields"

This reverts commit fdf8afce.

Fixes #1771.
parent c8a8f537
......@@ -118,7 +118,7 @@ pkgDescrFieldDescrs =
, simpleField "maintainer"
showFreeText parseFreeText
maintainer (\val pkg -> pkg{maintainer=val})
, nestedCommaListField "build-depends"
, commaListField "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})
, simpleNestedField "description"
, simpleField "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})
, nestedListField "data-files"
, listField "data-files"
showFilePath parseFilePathQ
dataFiles (\val pkg -> pkg{dataFiles=val})
, simpleField "data-dir"
showFilePath parseFilePathQ
dataDir (\val pkg -> pkg{dataDir=val})
, nestedListField "extra-source-files"
, listField "extra-source-files"
showFilePath parseFilePathQ
extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
, nestedListField "extra-tmp-files"
, listField "extra-tmp-files"
showFilePath parseFilePathQ
extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
, nestedListField "extra-doc-files"
, listField "extra-doc-files"
showFilePath parseFilePathQ
extraDocFiles (\val pkg -> pkg{extraDocFiles=val})
]
......@@ -178,7 +178,7 @@ storeXFieldsPD _ _ = Nothing
libFieldDescrs :: [FieldDescr Library]
libFieldDescrs =
[ nestedListField "exposed-modules" disp parseModuleNameQ
[ listField "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})
, nestedListField "c-sources"
, listField "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})
, nestedListField "extra-libraries"
, listField "extra-libraries"
showToken parseTokenQ
extraLibs (\xs binfo -> binfo{extraLibs=xs})
, listField "extra-lib-dirs"
showFilePath parseFilePathQ
extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
, nestedListField "includes"
, listField "includes"
showFilePath parseFilePathQ
includes (\paths binfo -> binfo{includes=paths})
, nestedListField "install-includes"
, listField "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})
, nestedListField "other-modules"
, listField "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, parens, char, nest, empty,
(hsep, comma, punctuate, fsep, parens, char, nest, empty,
isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
import Distribution.Simple.Utils (writeUTF8File)
import Distribution.ParseUtils (showFreeText, FieldDescr(..))
......@@ -79,14 +79,18 @@ ppSourceRepo repo =
ppFields :: [FieldDescr a] -> a -> Doc
ppFields fields x =
vcat [ (getter x) | FieldDescr _ getter _ <- fields ]
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 [ (getter x)
| FieldDescr _ 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]
......@@ -229,7 +233,7 @@ ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
ppDeps :: [Dependency] -> Doc
ppDeps [] = empty
ppDeps deps =
text "build-depends:" $+$ nest indentWith (vcat (punctuate comma (map disp deps)))
text "build-depends:" <+> fsep (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(..), ppFields, readFields, readFieldsFlat,
FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
showFields, showSingleNamedField, showSimpleSingleNamedField,
parseFields, parseFieldsFlat,
parseFilePathQ, parseTokenQ, parseTokenQ',
......@@ -32,9 +32,8 @@ module Distribution.ParseUtils (
parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
field, simpleField, simpleNestedField, listField, nestedListField,
spaceListField, commaListField, nestedCommaListField, commaNewLineListField,
optsField, liftField, boolField, parseQuoted, indentWith,
field, simpleField, listField, spaceListField, commaListField,
commaNewLineListField, optsField, liftField, boolField, parseQuoted,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -187,72 +186,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 (showField name showF) readF
= liftField get set $ field 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 (showField name showF') (parseCommaList readF)
where
set' xs b = set (get b ++ xs) b
showF' = fsep . punctuate comma . map showF
nestedCommaListField' :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
nestedCommaListField' separator name showF readF get set =
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 (showNestedField name showF') (parseCommaList readF)
field name (separator . punctuate comma . map 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
commaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
nestedCommaListField = nestedCommaListField' vcat
commaListField = commaListField' fsep
commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaNewLineListField = nestedCommaListField' sep
commaNewLineListField = commaListField' 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 (showField name showF') (parseSpaceList readF)
field name (fsep . map 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 (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)
field name (fsep . map 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 (showField name showF)
field name (hsep . map text)
(sepBy parseTokenQ' (munch1 isSpace))
where
update _ opts l | all null opts = l --empty opts as if no opts
......@@ -261,13 +234,12 @@ 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 (showField name showF) readF)
boolField name get set = liftField get set (FieldDescr name showF readF)
where
showF = text . show
readF line str _
......@@ -282,23 +254,11 @@ boolField name get set = liftField get set (FieldDescr name (showField name show
"The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
ppFields :: [FieldDescr a] -> a -> Doc
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
ppFields fields x = vcat [ ppField name (getter x)
| FieldDescr name getter _ <- fields]
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
ppField :: String -> Doc -> Doc
ppField name fielddoc = text name <> colon <+> fielddoc
showFields :: [FieldDescr a] -> a -> String
showFields fields = render . ($+$ text "") . ppFields fields
......@@ -307,7 +267,7 @@ showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
showSingleNamedField fields f =
case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
[] -> Nothing
(get:_) -> Just (render . get)
(get:_) -> Just (render . ppField f . get)
showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
showSimpleSingleNamedField fields f =
......@@ -758,7 +718,3 @@ 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