Include default flag values in --help

Fixes #893. The implementation strategy is to replace `First Bool` with
either a `First True` or `First False` so that we can use the type to
ensure we display the correct default. This results in a lot of changes
to the codebase, but they are all type directed.

Alternatively, we could introduce a typeclass here to reduce some
boilerplate, but I prefer the more explicit approach.

ChangeLog.md

@@ -136,6 +136,9 @@ Other enhancements:
   expiration verification just like `cabal --ignore-expiry` does.
   The flag is not enabled by default so that the default functionality
   is not changed.
+* Include default values for most command line flags in the `--help`
+  output. See
+  [#893](https://github.com/commercialhaskell/stack/issues/893).
 
 Bug fixes:
 

src/Options/Applicative/Builder/Extra.hs

@@ -7,15 +7,18 @@
 module Options.Applicative.Builder.Extra
   (boolFlags
   ,boolFlagsNoDefault
-  ,maybeBoolFlags
-  ,firstBoolFlags
+  ,firstBoolFlagsNoDefault
+  ,firstBoolFlagsTrue
+  ,firstBoolFlagsFalse
   ,enableDisableFlags
   ,enableDisableFlagsNoDefault
   ,extraHelpOption
   ,execExtraHelp
   ,textOption
   ,textArgument
   ,optionalFirst
+  ,optionalFirstTrue
+  ,optionalFirstFalse
   ,absFileOption
   ,relFileOption
   ,absDirOption
@@ -48,7 +51,13 @@ boolFlags :: Bool                 -- ^ Default value
           -> String               -- ^ Help suffix
           -> Mod FlagFields Bool
           -> Parser Bool
-boolFlags defaultValue = enableDisableFlags defaultValue True False
+boolFlags defaultValue name helpSuffix =
+  enableDisableFlags defaultValue True False name $ concat
+    [ helpSuffix
+    , " (default: "
+    , if defaultValue then "enabled" else "disabled"
+    , ")"
+    ]
 
 -- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>').
 boolFlagsNoDefault :: String               -- ^ Flag name
@@ -57,16 +66,24 @@ boolFlagsNoDefault :: String               -- ^ Flag name
                    -> Parser Bool
 boolFlagsNoDefault = enableDisableFlagsNoDefault True False
 
--- | Enable/disable flags for a @('Maybe' 'Bool')@.
-maybeBoolFlags :: String                       -- ^ Flag name
-               -> String                       -- ^ Help suffix
-               -> Mod FlagFields (Maybe Bool)
-               -> Parser (Maybe Bool)
-maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
+-- | Flag with no default of True or False
+firstBoolFlagsNoDefault :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
+firstBoolFlagsNoDefault name helpSuffix mod' =
+  First <$>
+  enableDisableFlags Nothing (Just True) (Just False)
+  name helpSuffix mod'
 
--- | Like 'maybeBoolFlags', but parsing a 'First'.
-firstBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
-firstBoolFlags long0 help0 mod0 = First <$> maybeBoolFlags long0 help0 mod0
+-- | Flag with a Semigroup instance and a default of True
+firstBoolFlagsTrue :: String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
+firstBoolFlagsTrue name helpSuffix =
+  enableDisableFlags mempty (FirstTrue (Just True)) (FirstTrue (Just False))
+  name $ helpSuffix ++ " (default: enabled)"
+
+-- | Flag with a Semigroup instance and a default of False
+firstBoolFlagsFalse :: String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
+firstBoolFlagsFalse name helpSuffix =
+  enableDisableFlags mempty (FirstFalse (Just False)) (FirstFalse (Just False))
+  name $ helpSuffix ++ " (default: disabled)"
 
 -- | Enable/disable flags for any type.
 enableDisableFlags :: a                 -- ^ Default value
@@ -161,6 +178,14 @@ textArgument = argument (T.pack <$> readerAsk)
 optionalFirst :: Alternative f => f a -> f (First a)
 optionalFirst = fmap First . optional
 
+-- | Like 'optional', but returning a 'FirstTrue'.
+optionalFirstTrue :: Alternative f => f Bool -> f FirstTrue
+optionalFirstTrue = fmap FirstTrue . optional
+
+-- | Like 'optional', but returning a 'FirstFalse'.
+optionalFirstFalse :: Alternative f => f Bool -> f FirstFalse
+optionalFirstFalse = fmap FirstFalse . optional
+
 absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
 absFileOption mods = option (eitherReader' parseAbsFile) $
   completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False }) <> mods

src/Stack/Build/Execute.hs

@@ -373,7 +373,7 @@ withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPacka
     toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))
 
     createTempDirFunction
-        | Just True <- boptsKeepTmpFiles bopts = withKeepSystemTempDir
+        | boptsKeepTmpFiles bopts = withKeepSystemTempDir
         | otherwise = withSystemTempDir
 
     dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()

src/Stack/Config.hs

@@ -223,13 +223,13 @@ configFromConfigMonoid
            "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
            configMonoidLatestSnapshot
          clConnectionCount = fromFirst 8 configMonoidConnectionCount
-         configHideTHLoading = fromFirst True configMonoidHideTHLoading
+         configHideTHLoading = fromFirstTrue configMonoidHideTHLoading
 
          configGHCVariant = getFirst configMonoidGHCVariant
          configGHCBuild = getFirst configMonoidGHCBuild
-         configInstallGHC = fromFirst True configMonoidInstallGHC
-         configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck
-         configSkipMsys = fromFirst False configMonoidSkipMsys
+         configInstallGHC = fromFirstTrue configMonoidInstallGHC
+         configSkipGHCCheck = fromFirstFalse configMonoidSkipGHCCheck
+         configSkipMsys = fromFirstFalse configMonoidSkipMsys
 
          configExtraIncludeDirs = configMonoidExtraIncludeDirs
          configExtraLibDirs = configMonoidExtraLibDirs
@@ -315,9 +315,9 @@ configFromConfigMonoid
          configGhcOptionsByCat = coerce configMonoidGhcOptionsByCat
          configSetupInfoLocations = configMonoidSetupInfoLocations
          configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds
-         configModifyCodePage = fromFirst True configMonoidModifyCodePage
+         configModifyCodePage = fromFirstTrue configMonoidModifyCodePage
          configExplicitSetupDeps = configMonoidExplicitSetupDeps
-         configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions
+         configRebuildGhcOptions = fromFirstFalse configMonoidRebuildGhcOptions
          configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
          configAllowNewer = fromFirst False configMonoidAllowNewer
          configDefaultTemplate = getFirst configMonoidDefaultTemplate

src/Stack/Config/Build.hs

@@ -10,71 +10,41 @@ import           Stack.Types.Config
 -- | Interprets BuildOptsMonoid options.
 buildOptsFromMonoid :: BuildOptsMonoid -> BuildOpts
 buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
-    { boptsLibProfile = fromFirst
-          (boptsLibProfile defaultBuildOpts)
+    { boptsLibProfile = fromFirstFalse
           (buildMonoidLibProfile <>
-           First (if tracing || profiling then Just True else Nothing))
-    , boptsExeProfile = fromFirst
-          (boptsExeProfile defaultBuildOpts)
+           FirstFalse (if tracing || profiling then Just True else Nothing))
+    , boptsExeProfile = fromFirstFalse
           (buildMonoidExeProfile <>
-           First (if tracing || profiling then Just True else Nothing))
-    , boptsLibStrip = fromFirst
-          (boptsLibStrip defaultBuildOpts)
+           FirstFalse (if tracing || profiling then Just True else Nothing))
+    , boptsLibStrip = fromFirstTrue
           (buildMonoidLibStrip <>
-           First (if noStripping then Just False else Nothing))
-    , boptsExeStrip = fromFirst
-          (boptsExeStrip defaultBuildOpts)
+           FirstTrue (if noStripping then Just False else Nothing))
+    , boptsExeStrip = fromFirstTrue
           (buildMonoidExeStrip <>
-           First (if noStripping then Just False else Nothing))
-    , boptsHaddock = fromFirst
-          (boptsHaddock defaultBuildOpts)
-          buildMonoidHaddock
+           FirstTrue (if noStripping then Just False else Nothing))
+    , boptsHaddock = fromFirstFalse buildMonoidHaddock
     , boptsHaddockOpts = haddockOptsFromMonoid buildMonoidHaddockOpts
-    , boptsOpenHaddocks = fromFirst
-          (boptsOpenHaddocks defaultBuildOpts)
-          buildMonoidOpenHaddocks
+    , boptsOpenHaddocks = fromFirstFalse buildMonoidOpenHaddocks
     , boptsHaddockDeps = getFirst buildMonoidHaddockDeps
-    , boptsHaddockInternal = fromFirst
-          (boptsHaddockInternal defaultBuildOpts)
-          buildMonoidHaddockInternal
-    , boptsHaddockHyperlinkSource = fromFirst
-          (boptsHaddockHyperlinkSource defaultBuildOpts)
-          buildMonoidHaddockHyperlinkSource
-    , boptsInstallExes = fromFirst
-          (boptsInstallExes defaultBuildOpts)
-          buildMonoidInstallExes
-    , boptsInstallCompilerTool = fromFirst
-          (boptsInstallCompilerTool defaultBuildOpts)
-          buildMonoidInstallCompilerTool
-    , boptsPreFetch = fromFirst
-          (boptsPreFetch defaultBuildOpts)
-          buildMonoidPreFetch
+    , boptsHaddockInternal = fromFirstFalse buildMonoidHaddockInternal
+    , boptsHaddockHyperlinkSource = fromFirstTrue buildMonoidHaddockHyperlinkSource
+    , boptsInstallExes = fromFirstFalse buildMonoidInstallExes
+    , boptsInstallCompilerTool = fromFirstFalse buildMonoidInstallCompilerTool
+    , boptsPreFetch = fromFirstFalse buildMonoidPreFetch
     , boptsKeepGoing = getFirst buildMonoidKeepGoing
-    , boptsKeepTmpFiles = getFirst buildMonoidKeepTmpFiles
-    , boptsForceDirty = fromFirst
-          (boptsForceDirty defaultBuildOpts)
-          buildMonoidForceDirty
-    , boptsTests = fromFirst (boptsTests defaultBuildOpts) buildMonoidTests
+    , boptsKeepTmpFiles = fromFirstFalse buildMonoidKeepTmpFiles
+    , boptsForceDirty = fromFirstFalse buildMonoidForceDirty
+    , boptsTests = fromFirstFalse buildMonoidTests
     , boptsTestOpts =
           testOptsFromMonoid buildMonoidTestOpts additionalArgs
-    , boptsBenchmarks = fromFirst
-          (boptsBenchmarks defaultBuildOpts)
-          buildMonoidBenchmarks
+    , boptsBenchmarks = fromFirstFalse buildMonoidBenchmarks
     , boptsBenchmarkOpts =
           benchmarkOptsFromMonoid buildMonoidBenchmarkOpts additionalArgs
-    , boptsReconfigure = fromFirst
-          (boptsReconfigure defaultBuildOpts)
-          buildMonoidReconfigure
-    , boptsCabalVerbose = fromFirst
-          (boptsCabalVerbose defaultBuildOpts)
-          buildMonoidCabalVerbose
-    , boptsSplitObjs = fromFirst
-          (boptsSplitObjs defaultBuildOpts)
-          buildMonoidSplitObjs
+    , boptsReconfigure = fromFirstFalse buildMonoidReconfigure
+    , boptsCabalVerbose = fromFirstFalse buildMonoidCabalVerbose
+    , boptsSplitObjs = fromFirstFalse buildMonoidSplitObjs
     , boptsSkipComponents = buildMonoidSkipComponents
-    , boptsInterleavedOutput = fromFirst
-          (boptsInterleavedOutput defaultBuildOpts)
-          buildMonoidInterleavedOutput
+    , boptsInterleavedOutput = fromFirstFalse buildMonoidInterleavedOutput
     , boptsDdumpDir = getFirst buildMonoidDdumpDir
     }
   where
@@ -105,10 +75,10 @@ haddockOptsFromMonoid HaddockOptsMonoid{..} =
 testOptsFromMonoid :: TestOptsMonoid -> Maybe [String] -> TestOpts
 testOptsFromMonoid TestOptsMonoid{..} madditional =
     defaultTestOpts
-    { toRerunTests = fromFirst (toRerunTests defaultTestOpts) toMonoidRerunTests
+    { toRerunTests = fromFirstTrue toMonoidRerunTests
     , toAdditionalArgs = fromMaybe [] madditional <> toMonoidAdditionalArgs
-    , toCoverage = fromFirst (toCoverage defaultTestOpts) toMonoidCoverage
-    , toDisableRun = fromFirst (toDisableRun defaultTestOpts) toMonoidDisableRun
+    , toCoverage = fromFirstFalse toMonoidCoverage
+    , toDisableRun = fromFirstFalse toMonoidDisableRun
     , toMaximumTimeSeconds = fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds
     }
 

src/Stack/Config/Docker.hs

@@ -69,9 +69,9 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do
                 dockerMonoidRegistryLogin
         dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)
         dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)
-        dockerAutoPull = fromFirst False dockerMonoidAutoPull
-        dockerDetach = fromFirst False dockerMonoidDetach
-        dockerPersist = fromFirst False dockerMonoidPersist
+        dockerAutoPull = fromFirstFalse dockerMonoidAutoPull
+        dockerDetach = fromFirstFalse dockerMonoidDetach
+        dockerPersist = fromFirstFalse dockerMonoidPersist
         dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName)
         dockerRunArgs = dockerMonoidRunArgs
         dockerMount = dockerMonoidMount

src/Stack/Config/Nix.hs

@@ -33,7 +33,7 @@ nixOptsFromMonoid NixOptsMonoid{..} os = do
         nixInitFile = getFirst nixMonoidInitFile
         nixShellOptions = fromFirst [] nixMonoidShellOptions
                           ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)
-        nixAddGCRoots   = fromFirst False nixMonoidAddGCRoots
+        nixAddGCRoots   = fromFirstFalse nixMonoidAddGCRoots
 
     -- Enable Nix-mode by default on NixOS, unless Docker-mode was specified
     osIsNixOS <- isNixOS

src/Stack/Options/BuildMonoidParser.hs

@@ -65,99 +65,102 @@ buildOptsMonoidParser hide0 =
                       \debugging symbols." <>
              hideExceptGhci)
     libProfiling =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "library-profiling"
             "library profiling for TARGETs and all its dependencies"
             hide
     exeProfiling =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "executable-profiling"
             "executable profiling for TARGETs and all its dependencies"
             hide
     libStripping =
-        firstBoolFlags
+        firstBoolFlagsTrue
             "library-stripping"
             "library stripping for TARGETs and all its dependencies"
             hide
     exeStripping =
-        firstBoolFlags
+        firstBoolFlagsTrue
             "executable-stripping"
             "executable stripping for TARGETs and all its dependencies"
             hide
     haddock =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "haddock"
             "generating Haddocks the package(s) in this directory/configuration"
             hide
     openHaddocks =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "open"
             "opening the local Haddock documentation in the browser"
             hide
     haddockDeps =
-        firstBoolFlags "haddock-deps" "building Haddocks for dependencies" hide
+        firstBoolFlagsNoDefault
+            "haddock-deps"
+            "building Haddocks for dependencies (default: true if building Haddocks, false otherwise)"
+            hide
     haddockInternal =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "haddock-internal"
             "building Haddocks for internal modules (like cabal haddock --internal)"
             hide
     haddockHyperlinkSource =
-        firstBoolFlags
+        firstBoolFlagsTrue
             "haddock-hyperlink-source"
             "building hyperlinked source for Haddock (like haddock --hyperlinked-source)"
             hide
     copyBins =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "copy-bins"
             "copying binaries to the local-bin-path (see 'stack path')"
             hide
     copyCompilerTool =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "copy-compiler-tool"
             "copying binaries of targets to compiler-tools-bin (see 'stack path')"
             hide
     keepGoing =
-        firstBoolFlags
+        firstBoolFlagsNoDefault
             "keep-going"
             "continue running after a step fails (default: false for build, true for test/bench)"
             hide
     keepTmpFiles =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "keep-tmp-files"
-            "keep intermediate files and build directories (default: false)"
+            "keep intermediate files and build directories"
             hide
     preFetch =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "prefetch"
              "Fetch packages necessary for the build immediately, useful with --dry-run"
              hide
     forceDirty =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "force-dirty"
             "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change"
             hide
     tests =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "test"
             "testing the package(s) in this directory/configuration"
             hideExceptGhci
     benches =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "bench"
             "benchmarking the package(s) in this directory/configuration"
             hideExceptGhci
     reconfigure =
-        firstBoolFlags
+        firstBoolFlagsFalse
              "reconfigure"
              "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files"
             hide
     cabalVerbose =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "cabal-verbose"
             "Ask Cabal to be verbose in its output"
             hide
     splitObjs =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "split-objs"
             ("Enable split-objs, to reduce output size (at the cost of build time). " ++ splitObjsWarning)
             hide
@@ -169,7 +172,7 @@ buildOptsMonoidParser hide0 =
                  help "Skip given component, can be specified multiple times" <>
                  hide)))
     interleavedOutput =
-        firstBoolFlags
+        firstBoolFlagsFalse
             "interleaved-output"
             "Print concurrent GHC output to the console with a prefix for the package name"
             hide