Add NoFlagValue type class

Author: zlonast

Cabal-syntax/src/Distribution/Parsec.hs

@@ -60,7 +60,6 @@ module Distribution.Parsec
 
 import Data.ByteString (ByteString)
 import Data.Char (digitToInt, intToDigit)
-import Data.Functor (($>))
 import Data.List (transpose)
 import Distribution.CabalSpecVersion
 import Distribution.Compat.Prelude
@@ -253,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 $> True
-        | lstr == "false" = parsecWarning PWTBoolCase caseWarning $> 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/src/Distribution/Simple/Build.hs

@@ -309,7 +309,7 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
     removeFileForcibly buildInfoFile
   where
     buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref
-    shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo
+    shouldDumpBuildInfo = fromNoFlag dumpBuildInfoFlag == DumpBuildInfo
 
     -- \| Given the flavor of the compiler, try to find out
     -- which program we need.

Cabal/src/Distribution/Simple/Flag.hs

@@ -30,8 +30,9 @@ module Distribution.Simple.Flag
   , flagToList
   , maybeToFlag
   , mergeListFlag
-  , fromFlagOrMonoid
   , BooleanFlag (..)
+  , NoFlagValue (..)
+  , fromNoFlag
   ) where
 
 import Data.Monoid (Last (..))
@@ -87,10 +88,6 @@ fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault"
 fromFlagOrDefault :: a -> Flag a -> a
 fromFlagOrDefault def = fromMaybe def . getLast
 
--- | Extracts a value from a 'Flag', and returns the mempty value on 'NoFlag'.
-fromFlagOrMonoid :: Monoid a => Flag a -> a
-fromFlagOrMonoid = fromFlagOrDefault mempty
-
 -- | Converts a 'Flag' value to a 'Maybe' value.
 flagToMaybe :: Flag a -> Maybe a
 flagToMaybe = getLast
@@ -128,3 +125,15 @@ class BooleanFlag a where
 
 instance BooleanFlag Bool where
   asBool = id
+
+-- | Flag is a Monoid, with 'NoFlag' as the identity element, and 'Flag' as the binary operation.
+--
+-- @since 3.18.0.0
+class NoFlagValue a where
+  noFlagValue :: a
+
+-- | Extracts a value from a 'Flag', and returns the 'noFlagValue' on 'NoFlag'.
+--
+-- @since 3.18.0.0
+fromNoFlag :: NoFlagValue a => Flag a -> a
+fromNoFlag = fromFlagOrDefault noFlagValue

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

@@ -579,11 +579,15 @@ configureOptions showOrParseArgs =
               (Flag . fromString)
               ( \case
                   NoFlag -> []
-                  flag -> [OptimisationLevel.toString $ fromFlagOrMonoid flag]
+                  Flag flag -> [OptimisationLevel.toString flag]
               )
               "O"
               ["enable-optimization", "enable-optimisation"]
-              "Build with optimization (n is 0--2, default is 1)"
+              ( let minLevel = OptimisationLevel.toString minBound
+                    maxLevel = OptimisationLevel.toString maxBound
+                    def = OptimisationLevel.toString noFlagValue
+                 in "Build with optimization (n is " ++ minLevel ++ "--" ++ maxLevel ++ ", default is " ++ def ++ ")"
+              )
           , noArg
               (Flag NoOptimisation)
               []
@@ -599,11 +603,15 @@ configureOptions showOrParseArgs =
               (Flag . fromString)
               ( \case
                   NoFlag -> []
-                  flag -> [DebugInfoLevel.toString $ fromFlagOrMonoid flag]
+                  Flag flag -> [DebugInfoLevel.toString flag]
               )
               "g"
               ["enable-debug-info"]
-              "Emit debug info (n is 0--3, default is 0)"
+              ( let minLevel = DebugInfoLevel.toString minBound
+                    maxLevel = DebugInfoLevel.toString maxBound
+                    def = DebugInfoLevel.toString noFlagValue
+                 in "Emit debug info (n is " ++ minLevel ++ "--" ++ maxLevel ++ ", default is " ++ def ++ ")"
+              )
           , noArg
               (Flag NoDebugInfo)
               []

Cabal/src/Distribution/Types/DebugInfoLevel.hs

@@ -15,6 +15,7 @@ import Distribution.Parsec (CabalParsing, Parsec (..))
 import Prelude ()
 
 import Data.Bool (bool)
+import Distribution.Simple.Flag (NoFlagValue (..))
 
 -- ------------------------------------------------------------
 
@@ -36,25 +37,17 @@ instance Binary DebugInfoLevel
 instance NFData DebugInfoLevel
 instance Structured DebugInfoLevel
 
+instance NoFlagValue DebugInfoLevel where
+  noFlagValue :: DebugInfoLevel
+  noFlagValue = NoDebugInfo
+
 instance Parsec DebugInfoLevel where
   parsec :: CabalParsing m => m DebugInfoLevel
   parsec = boolParser <|> intParser
     where
       boolParser = bool NoDebugInfo NormalDebugInfo <$> parsec
       intParser = intToDebugInfoLevel <$> integral
 
-instance Ord DebugInfoLevel where
-  compare :: DebugInfoLevel -> DebugInfoLevel -> Ordering
-  compare = comparing fromEnum
-
-instance Semigroup DebugInfoLevel where
-  (<>) :: DebugInfoLevel -> DebugInfoLevel -> DebugInfoLevel
-  (<>) = max
-
-instance Monoid DebugInfoLevel where
-  mempty :: DebugInfoLevel
-  mempty = NoDebugInfo
-
 instance IsString DebugInfoLevel where
   fromString :: String -> DebugInfoLevel
   fromString s = case reads s of

Cabal/src/Distribution/Types/DumpBuildInfo.hs

@@ -10,6 +10,7 @@ module Distribution.Types.DumpBuildInfo
 
 import Distribution.Compat.Prelude (Binary, Generic, NFData, Structured)
 import Distribution.Parsec (CabalParsing, Parsec (..))
+import Distribution.Simple.Flag (NoFlagValue (..))
 
 data DumpBuildInfo
   = NoDumpBuildInfo
@@ -20,6 +21,10 @@ instance Binary DumpBuildInfo
 instance NFData DumpBuildInfo
 instance Structured DumpBuildInfo
 
+instance NoFlagValue DumpBuildInfo where
+  noFlagValue :: DumpBuildInfo
+  noFlagValue = NoDumpBuildInfo
+
 instance Parsec DumpBuildInfo where
   parsec :: CabalParsing m => m DumpBuildInfo
   parsec = boolToDumpBuildInfo <$> parsec

Cabal/src/Distribution/Types/OptimisationLevel.hs

@@ -15,6 +15,7 @@ import Distribution.Parsec (CabalParsing, Parsec (..))
 import Prelude ()
 
 import Data.Bool (bool)
+import Distribution.Simple.Flag (NoFlagValue (..))
 
 -- ------------------------------------------------------------
 
@@ -35,25 +36,17 @@ instance Binary OptimisationLevel
 instance NFData OptimisationLevel
 instance Structured OptimisationLevel
 
+instance NoFlagValue OptimisationLevel where
+  noFlagValue :: OptimisationLevel
+  noFlagValue = NormalOptimisation
+
 instance Parsec OptimisationLevel where
   parsec :: CabalParsing m => m OptimisationLevel
   parsec = boolParser <|> intParser
     where
       boolParser = bool NoOptimisation NormalOptimisation <$> parsec
       intParser = intToOptimisationLevel <$> integral
 
-instance Ord OptimisationLevel where
-  compare :: OptimisationLevel -> OptimisationLevel -> Ordering
-  compare = comparing fromEnum
-
-instance Semigroup OptimisationLevel where
-  (<>) :: OptimisationLevel -> OptimisationLevel -> OptimisationLevel
-  (<>) = max
-
-instance Monoid OptimisationLevel where
-  mempty :: OptimisationLevel
-  mempty = NormalOptimisation
-
 instance IsString OptimisationLevel where
   fromString :: String -> OptimisationLevel
   fromString s = case reads s of

cabal-install/src/Distribution/Client/ProjectOrchestration.hs

@@ -190,7 +190,7 @@ import Distribution.Simple.Compiler
   , showCompilerId
   )
 import Distribution.Simple.Configure (computeEffectiveProfiling)
-import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, fromFlagOrMonoid)
+import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, fromNoFlag)
 import Distribution.Simple.LocalBuildInfo
   ( ComponentName (..)
   , pkgComponents
@@ -1255,7 +1255,7 @@ printPlan
         "Build profile: "
           ++ unwords
             [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared
-            , "-O" ++ (OptimisationLevel.toString . fromFlagOrMonoid) (globalOptimization <> localOptimization)
+            , "-O" ++ (OptimisationLevel.toString . fromNoFlag) (globalOptimization <> localOptimization)
             ]
           ++ "\n"
 

cabal-install/src/Distribution/Client/ScriptUtils.hs

@@ -122,7 +122,7 @@ import Distribution.Simple.Compiler
   )
 import Distribution.Simple.Flag
   ( flagToMaybe
-  , fromFlagOrDefault
+  , fromNoFlag
   )
 import Distribution.Simple.PackageDescription
   ( parseString
@@ -193,7 +193,6 @@ import qualified Data.ByteString.Char8 as BS
 import Data.ByteString.Lazy ()
 import qualified Data.Set as S
 import Distribution.Client.Errors
-import Distribution.Types.OptimisationLevel (OptimisationLevel (..))
 import Distribution.Utils.Path
   ( unsafeMakeSymbolicPath
   )
@@ -434,7 +433,7 @@ scriptDistDirParams scriptPath ctx compiler platform =
     , distParamComponentName = Just $ CExeName cn
     , distParamCompilerId = compilerId compiler
     , distParamPlatform = platform
-    , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization
+    , distParamOptimization = fromNoFlag optimization
     }
   where
     cn = scriptComponentName scriptPath