diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 1f904d4309eed7eb4ccb3cafa63cd095445787ae..9d4fbf5fb9c4f95baca9b281210d0143adac0172 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -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 diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 16c65fdad302d0f5363f20c576c892081ee50057..597bd2c5c82077c87d27dce8a3d5eaaeba63af52 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -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 diff --git a/Cabal/Distribution/ParseUtils.hs b/Cabal/Distribution/ParseUtils.hs index d774ba5a0f9416f20ce60c6ce5f6579143583288..cf1f6ca9a59079f4928c2622103a4553366c4871 100644 --- a/Cabal/Distribution/ParseUtils.hs +++ b/Cabal/Distribution/ParseUtils.hs @@ -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