Parse Bool fields using more cunning, allow new parses with a warning

We want to allow case-insensitive parsing however we don't want
packages being uploaded to hackage that will break older versions of
Cabal. If we allow new valid parses then we will end up breaking
stuff. So what we really want to do is allow new parses but warn if
they're not ones that older versions of Cabal would have allowed. So
long as hackage rejects pakcages that have parse warnings then we can
prevent new .cabal files appearing on hackage that would break older
Cabal versions. Our current parser (ReadP) does not support warnings
so we have to handle the bool fields specially in the parser wrapper
layer that we added to handle errors and warnings. This can go away
when we use a parser with support for error and warning messages.

Author: dcoutts

Distribution/InstalledPackageInfo.hs

@@ -58,7 +58,7 @@ import Distribution.ParseUtils (
 	FieldDescr(..), readFields, ParseResult(..), PError(..), PWarning,
 	Field(F), simpleField, listField, parseLicenseQ, ppField, ppFields,
 	parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ,
-	showFilePath, showToken, parseOptVersion, parseQuoted,
+	showFilePath, showToken, boolField, parseOptVersion, parseQuoted,
 	showFreeText)
 import Distribution.License 	( License(..) )
 import Distribution.Package
@@ -238,8 +238,7 @@ parseFreeText = ReadP.munch (const True)
 
 installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
 installedFieldDescrs = [
-   simpleField "exposed"
-	disp               parse
+   boolField "exposed"
 	exposed     	   (\val pkg -> pkg{exposed=val})
  , listField   "exposed-modules"
 	text               parseModuleNameQ

Distribution/PackageDescription/Parse.hs

@@ -201,8 +201,7 @@ storeXFieldsExe _ _ = Nothing
 
 binfoFieldDescrs :: [FieldDescr BuildInfo]
 binfoFieldDescrs =
- [ simpleField "buildable"
-           disp               parse
+ [ boolField "buildable"
            buildable          (\val binfo -> binfo{buildable=val})
  , commaListField  "build-tools"
            disp               parseBuildTool
@@ -276,8 +275,7 @@ flagFieldDescrs =
     [ simpleField "description"
         showFreeText     (munch (const True))
         flagDescription  (\val fl -> fl{ flagDescription = val })
-    , simpleField "default"
-        disp             parse
+    , boolField "default"
         flagDefault      (\val fl -> fl{ flagDefault = val })
     ]
 

Distribution/ParseUtils.hs

@@ -55,7 +55,7 @@ module Distribution.ParseUtils (
 	parseSepList, parseCommaList, parseOptCommaList,
 	showFilePath, showToken, showTestedWith, showFreeText,
 	field, simpleField, listField, commaListField, optsField, liftField,
-        parseQuoted,
+        boolField, parseQuoted,
 
         UnrecFieldParser, warnUnrec, ignoreUnrec,
   ) where
@@ -68,7 +68,7 @@ import Distribution.Compat.ReadP as ReadP hiding (get)
 import Distribution.ReadE
 import Distribution.Text
          ( Text(..) )
-import Distribution.Simple.Utils (intercalate)
+import Distribution.Simple.Utils (intercalate, lowercase)
 import Language.Haskell.Extension (Extension)
 
 import Text.PrettyPrint.HughesPJ hiding (braces)
@@ -206,6 +206,24 @@ optsField name flavor get set =
            | f == f'   = (f, opts ++ opts') : rest
            | otherwise = (f',opts') : update f opts rest
 
+-- 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 framwork!
+boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
+boolField name get set = liftField get set (FieldDescr name showF readF)
+  where
+    showF = text . show
+    readF line str _
+      |  str == "True"  = ParseOk [] True
+      |  str == "False" = ParseOk [] False
+      | lstr == "true"  = ParseOk [caseWarning] True
+      | lstr == "false" = ParseOk [caseWarning] False
+      | otherwise       = ParseFailed (NoParse name line)
+      where
+        lstr = lowercase str
+        caseWarning = PWarning
+          "Bool fields are case sensitive, use 'True' or 'False'."
+
 ppFields :: a -> [FieldDescr a] -> Doc
 ppFields _ [] = empty
 ppFields pkg' ((FieldDescr name getter _):flds) =