Allow case insensitive bools and move to numeric render

Co-authored-by: Jappie Klooster <jappieklooster@hotmail.com>

Author: zlonast

Cabal-syntax/src/Distribution/Parsec.hs

@@ -252,15 +252,11 @@ instance Parsec Bool where
   parsec = P.munch1 isAlpha >>= postprocess
     where
       postprocess str
-        | str == "True" = pure True
-        | str == "False" = pure False
-        | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True
-        | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False
+        | lstr == "true" = pure True
+        | lstr == "false" = pure False
         | otherwise = fail $ "Not a boolean: " ++ str
         where
           lstr = map toLower str
-          caseWarning =
-            "Boolean values are case sensitive, use 'True' or 'False'."
 
 instance Parsec a => Parsec (Last a) where
   parsec = parsecLast

Cabal-syntax/src/Distribution/Parsec/Warning.hs

@@ -25,8 +25,6 @@ data PWarnType
     PWTOther
   | -- | Invalid UTF encoding
     PWTUTF
-  | -- | @true@ or @false@, not @True@ or @False@
-    PWTBoolCase
   | -- | there are version with tags
     PWTVersionTag
   | -- | New syntax used, but no @cabal-version: >= 1.2@ specified

Cabal-tests/tests/ParserTests.hs

@@ -68,7 +68,6 @@ warningTests = testGroup "warnings triggered"
     , warningTest PWTLexNBSP           "nbsp.cabal"
     , warningTest PWTLexTab            "tab.cabal"
     , warningTest PWTUTF               "utf8.cabal"
-    , warningTest PWTBoolCase          "bool.cabal"
     , warningTest PWTVersionTag        "versiontag.cabal"
     , warningTest PWTNewSyntax         "newsyntax.cabal"
     , warningTest PWTOldSyntax         "oldsyntax.cabal"

Cabal-tests/tests/ParserTests/warnings/bool.cabal

@@ -79,7 +79,6 @@ module Distribution.Simple.Command
   , reqArg'
   , optArg
   , optArg'
-  , optArgDef'
   , noArg
   , boolOpt
   , boolOpt'
@@ -280,15 +279,6 @@ optArg'
 optArg' ad mkflag showflag =
   optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag
 
-optArgDef'
-  :: Monoid b
-  => ArgPlaceHolder
-  -> (String, Maybe String -> b)
-  -> (b -> [Maybe String])
-  -> MkOptDescr (a -> b) (b -> a -> a) a
-optArgDef' ad (dv, mkflag) showflag =
-  optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag
-
 noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
 noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d
 

Cabal/src/Distribution/Simple/Command.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 
@@ -54,11 +56,13 @@ module Distribution.Simple.Compiler
 
     -- * Support for optimisation levels
   , OptimisationLevel (..)
-  , flagToOptimisationLevel
+  , toOptimisationLevel
+  , fromOptimisationLevel
 
     -- * Support for debug info levels
   , DebugInfoLevel (..)
-  , flagToDebugInfoLevel
+  , toDebugInfoLevel
+  , fromDebugInfoLevel
 
     -- * Support for language extensions
   , CompilerFlag
@@ -112,6 +116,7 @@ import Language.Haskell.Extension
 
 import Data.Bool (bool)
 import qualified Data.Map as Map (lookup)
+import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag)
 import System.Directory (canonicalizePath)
 
 data Compiler = Compiler
@@ -329,12 +334,16 @@ parsecOptimisationLevel = boolParser <|> intParser
     boolParser = bool NoOptimisation NormalOptimisation <$> parsec
     intParser = intToOptimisationLevel <$> integral
 
-flagToOptimisationLevel :: Maybe String -> OptimisationLevel
-flagToOptimisationLevel Nothing = NormalOptimisation
-flagToOptimisationLevel (Just s) = case reads s of
+toOptimisationLevel :: String -> OptimisationLevel
+toOptimisationLevel s = case reads s of
   [(i, "")] -> intToOptimisationLevel i
   _ -> error $ "Can't parse optimisation level " ++ s
 
+fromOptimisationLevel :: Flag OptimisationLevel -> String
+fromOptimisationLevel = \case
+  Flag op -> show $ fromEnum op
+  NoFlag -> "1"
+
 intToOptimisationLevel :: Int -> OptimisationLevel
 intToOptimisationLevel i
   | i >= minLevel && i <= maxLevel = toEnum i
@@ -374,22 +383,33 @@ instance Parsec DebugInfoLevel where
   parsec = parsecDebugInfoLevel
 
 parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel
-parsecDebugInfoLevel = flagToDebugInfoLevel . pure <$> parsecToken
-
-flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
-flagToDebugInfoLevel Nothing = NormalDebugInfo
-flagToDebugInfoLevel (Just s) = case reads s of
-  [(i, "")]
-    | i >= fromEnum (minBound :: DebugInfoLevel)
-        && i <= fromEnum (maxBound :: DebugInfoLevel) ->
-        toEnum i
-    | otherwise ->
-        error $
-          "Bad debug info level: "
-            ++ show i
-            ++ ". Valid values are 0..3"
+parsecDebugInfoLevel = boolParser <|> intParser
+  where
+    boolParser = bool NoDebugInfo NormalDebugInfo <$> parsec
+    intParser = intToDebugInfoLevel <$> integral
+
+toDebugInfoLevel :: String -> DebugInfoLevel
+toDebugInfoLevel s = case reads s of
+  [(i, "")] -> intToDebugInfoLevel i
   _ -> error $ "Can't parse debug info level " ++ s
 
+fromDebugInfoLevel :: Flag DebugInfoLevel -> String
+fromDebugInfoLevel = \case
+  Flag db -> show $ fromEnum db
+  NoFlag -> "0"
+
+intToDebugInfoLevel :: Int -> DebugInfoLevel
+intToDebugInfoLevel i
+  | i >= minLevel && i <= maxLevel = toEnum i
+  | otherwise =
+      error $
+        "Bad debug info level: "
+          ++ show i
+          ++ ". Valid values are 0..3"
+  where
+    minLevel = fromEnum (minBound :: DebugInfoLevel)
+    maxLevel = fromEnum (maxBound :: DebugInfoLevel)
+
 -- ------------------------------------------------------------
 
 -- * Languages and Extensions

Cabal/src/Distribution/Simple/Compiler.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -569,14 +570,12 @@ configureOptions showOrParseArgs =
           "optimization"
           configOptimization
           (\v flags -> flags{configOptimization = v})
-          [ optArgDef'
+          [ reqArg'
               "n"
-              (show NoOptimisation, Flag . flagToOptimisationLevel)
-              ( \f -> case f of
-                  Flag NoOptimisation -> []
-                  Flag NormalOptimisation -> [Nothing]
-                  Flag MaximumOptimisation -> [Just "2"]
-                  _ -> []
+              (Flag . toOptimisationLevel)
+              ( \case
+                  NoFlag -> []
+                  flag -> [fromOptimisationLevel flag]
               )
               "O"
               ["enable-optimization", "enable-optimisation"]
@@ -591,17 +590,14 @@ configureOptions showOrParseArgs =
           "debug-info"
           configDebugInfo
           (\v flags -> flags{configDebugInfo = v})
-          [ optArg'
+          [ reqArg'
               "n"
-              (Flag . flagToDebugInfoLevel)
-              ( \f -> case f of
-                  Flag NoDebugInfo -> []
-                  Flag MinimalDebugInfo -> [Just "1"]
-                  Flag NormalDebugInfo -> [Nothing]
-                  Flag MaximalDebugInfo -> [Just "3"]
-                  _ -> []
+              (Flag . toDebugInfoLevel)
+              ( \case
+                  NoFlag -> []
+                  flag -> [fromDebugInfoLevel flag]
               )
-              ""
+              "g"
               ["enable-debug-info"]
               "Emit debug info (n is 0--3, default is 0)"
           , noArg

Cabal/src/Distribution/Simple/Setup/Config.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Distribution.Types.DumpBuildInfo
   ( DumpBuildInfo (..)
+  , fromDumpBuildInfo
   ) where
 
-import Distribution.Compat.Prelude
-import Distribution.Parsec
+import Distribution.Compat.Prelude (Binary, Generic, NFData, Structured)
+import Distribution.Parsec (CabalParsing, Parsec (..))
 
 data DumpBuildInfo
   = NoDumpBuildInfo
@@ -24,3 +26,8 @@ parsecDumpBuildInfo = boolToDumpBuildInfo <$> parsec
 
 boolToDumpBuildInfo :: Bool -> DumpBuildInfo
 boolToDumpBuildInfo bool = if bool then DumpBuildInfo else NoDumpBuildInfo
+
+fromDumpBuildInfo :: DumpBuildInfo -> String
+fromDumpBuildInfo = \case
+  NoDumpBuildInfo -> "False"
+  DumpBuildInfo -> "True"

Cabal/src/Distribution/Types/DumpBuildInfo.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
@@ -137,7 +138,6 @@ import Distribution.Compiler
 import Distribution.Deprecated.ParseUtils
   ( FieldDescr (..)
   , PError (..)
-  , PWarning (..)
   , ParseResult (..)
   , liftField
   , lineNo
@@ -166,8 +166,8 @@ import Distribution.Simple.Command
   , commandDefaultFlags
   )
 import Distribution.Simple.Compiler
-  ( DebugInfoLevel (..)
-  , OptimisationLevel (..)
+  ( fromDebugInfoLevel
+  , fromOptimisationLevel
   )
 import Distribution.Simple.InstallDirs
   ( InstallDirs (..)
@@ -1189,75 +1189,29 @@ configFieldDescriptions src =
           (Flag <$> parsec <|> pure NoFlag)
           configHcFlavor
           (\v flags -> flags{configHcFlavor = v})
-      , -- TODO: The following is a temporary fix. The "optimization"
-        -- and "debug-info" fields are OptArg, and viewAsFieldDescr
-        -- fails on that. Instead of a hand-written hackaged parser
-        -- and printer, we should handle this case properly in the
-        -- library.
-        liftField
-          configOptimization
-          ( \v flags ->
-              flags{configOptimization = v}
-          )
-          $ let name = "optimization"
-             in FieldDescr
-                  name
-                  ( \f -> case f of
-                      Flag NoOptimisation -> Disp.text "False"
-                      Flag NormalOptimisation -> Disp.text "True"
-                      Flag MaximumOptimisation -> Disp.text "2"
-                      _ -> Disp.empty
-                  )
-                  ( \line str _ -> case () of
-                      _
-                        | str == "False" -> ParseOk [] (Flag NoOptimisation)
-                        | str == "True" -> ParseOk [] (Flag NormalOptimisation)
-                        | str == "0" -> ParseOk [] (Flag NoOptimisation)
-                        | str == "1" -> ParseOk [] (Flag NormalOptimisation)
-                        | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
-                        | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
-                        | lstr == "true" ->
-                            ParseOk
-                              [caseWarning]
-                              (Flag NormalOptimisation)
-                        | otherwise -> ParseFailed (NoParse name line)
-                        where
-                          lstr = lowercase str
-                          caseWarning =
-                            PWarning $
-                              "The '"
-                                ++ name
-                                ++ "' field is case sensitive, use 'True' or 'False'."
-                  )
+      , liftField configOptimization (\v flags -> flags{configOptimization = v}) $
+          let name = "optimization"
+           in FieldDescr
+                name
+                ( \case
+                    NoFlag -> Disp.empty
+                    flag -> Disp.text $ fromOptimisationLevel flag
+                )
+                ( \line str _ -> case maybe NoFlag Flag (simpleParsec str) of
+                    NoFlag -> ParseFailed (NoParse name line)
+                    flag -> ParseOk [] flag
+                )
       , liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $
           let name = "debug-info"
            in FieldDescr
                 name
-                ( \f -> case f of
-                    Flag NoDebugInfo -> Disp.text "False"
-                    Flag MinimalDebugInfo -> Disp.text "1"
-                    Flag NormalDebugInfo -> Disp.text "True"
-                    Flag MaximalDebugInfo -> Disp.text "3"
-                    _ -> Disp.empty
+                ( \case
+                    NoFlag -> Disp.empty
+                    flag -> Disp.text $ fromDebugInfoLevel flag
                 )
-                ( \line str _ -> case () of
-                    _
-                      | str == "False" -> ParseOk [] (Flag NoDebugInfo)
-                      | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
-                      | str == "0" -> ParseOk [] (Flag NoDebugInfo)
-                      | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
-                      | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
-                      | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
-                      | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
-                      | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
-                      | otherwise -> ParseFailed (NoParse name line)
-                      where
-                        lstr = lowercase str
-                        caseWarning =
-                          PWarning $
-                            "The '"
-                              ++ name
-                              ++ "' field is case sensitive, use 'True' or 'False'."
+                ( \line str _ -> case maybe NoFlag Flag (simpleParsec str) of
+                    NoFlag -> ParseFailed (NoParse name line)
+                    flag -> ParseOk [] flag
                 )
       ]
     ++ toSavedConfig