Commit 270957ea authored by Mikhail Glushenkov's avatar Mikhail Glushenkov

Revert "Merge branch 'master' of https://github.com/dan-t/cabal"

This reverts commit 0038d05a, reversing
changes made to c721e851.
parent 4ab6a752
......@@ -106,7 +106,7 @@ pkgDescrFieldDescrs =
[x] -> x
_ -> "")
(\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})
, spaceListField "license-files"
, listField "license-files"
showFilePath parseFilePathQ
(\pkg -> case licenseFiles pkg of
[_] -> []
......@@ -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"
......@@ -397,7 +397,7 @@ binfoFieldDescrs =
, commaListField "pkgconfig-depends"
disp parsePkgconfigDependency
pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})
, spaceListField "frameworks"
, listField "frameworks"
showToken parseTokenQ
frameworks (\val binfo -> binfo{frameworks=val})
, listField "c-sources"
......@@ -407,7 +407,7 @@ binfoFieldDescrs =
, simpleField "default-language"
(maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
, spaceListField "other-languages"
, listField "other-languages"
disp parseLanguageQ
otherLanguages (\langs binfo -> binfo{otherLanguages=langs})
, listField "default-extensions"
......@@ -435,16 +435,16 @@ binfoFieldDescrs =
, listField "include-dirs"
showFilePath parseFilePathQ
includeDirs (\paths binfo -> binfo{includeDirs=paths})
, spaceListField "hs-source-dirs"
, listField "hs-source-dirs"
showFilePath parseFilePathQ
hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
, listField "other-modules"
disp parseModuleNameQ
otherModules (\val binfo -> binfo{otherModules=val})
, spaceListField "ghc-prof-options"
, listField "ghc-prof-options"
text parseTokenQ
ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})
, spaceListField "ghc-shared-options"
, listField "ghc-shared-options"
text parseTokenQ
ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})
, optsField "ghc-options" GHC
......
......@@ -27,16 +27,19 @@ 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(..), indentWith)
import Distribution.ParseUtils (showFreeText, FieldDescr(..))
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
......@@ -76,14 +79,18 @@ ppSourceRepo repo =
ppFields :: [FieldDescr a] -> a -> Doc
ppFields fields x =
vcat [ (getter x) | FieldDescr name 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 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]
......@@ -226,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,8 +32,8 @@ module Distribution.ParseUtils (
parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
parseSepList, parseCommaList, parseOptCommaList,
showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
field, simpleField, simpleNestedField, listField, spaceListField, commaListField,
commaNewLineListField, optsField, liftField, boolField, parseQuoted, indentWith,
field, simpleField, listField, spaceListField, commaListField,
commaNewLineListField, optsField, liftField, boolField, parseQuoted,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -186,21 +186,15 @@ 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
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
= 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 (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
commaListField :: String -> (a -> Doc) -> ReadP [a] a
-> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
......@@ -214,26 +208,24 @@ 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
listField 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
......@@ -242,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 _
......@@ -263,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]
ppFields fields x = vcat [ ppField name (getter x)
| FieldDescr name 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
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
......@@ -288,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 =
......@@ -739,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