options: combine default enable/disable option in help

commercialhaskell · Aug 26, 2015 · d45a05a · d45a05a
1 parent 41a071e
commit d45a05a
Showing 1 changed file with 38 additions and 26 deletions.
diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs
@@ -25,44 +25,56 @@ boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
 boolFlags defaultValue = enableDisableFlags defaultValue True False
 
 -- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s).
-boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool
+boolFlagsNoDefault :: (Maybe Bool) -> String -> String -> Mod FlagFields Bool -> Parser Bool
 boolFlagsNoDefault = enableDisableFlagsNoDefault True False
 
 -- | Enable/disable flags for a @(Maybe Bool)@.
 maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool)
 maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
 
 -- | Enable/disable flags for any type.
-enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlags :: (Eq a) => a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
 enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
-  enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|>
+  enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|>
   pure defaultValue
 
 -- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s)
-enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
-enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =
-  last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods)
+enableDisableFlagsNoDefault :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods =
+  last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods)
 
-enableDisableFlagsNoDefault' :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
-enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods =
-  flag' enabledValue
-        (long name <>
-         help ("Enable " ++ helpSuffix) <>
-         mods) <|>
-  flag' enabledValue
-        (internal <>
-         long ("enable-" ++ name) <>
-         help ("Enable " ++ helpSuffix) <>
-         mods) <|>
-  flag' disabledValue
-        (long ("no-" ++ name) <>
-         help ("Disable " ++ helpSuffix) <>
-         mods) <|>
-  flag' disabledValue
-        (internal <>
-         long ("disable-" ++ name) <>
-         help ("Disable " ++ helpSuffix) <>
-         mods)
+enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods =
+    let hideEnabled = Just enabledValue == maybeHideValue
+        hideDisabled = Just disabledValue == maybeHideValue
+    in flag'
+           enabledValue
+           ((if hideEnabled
+                 then hidden <> internal
+                 else idm) <>
+            long name <>
+            help
+                (concat $ concat
+                     [ ["Enable ", helpSuffix]
+                     , [" (--no-" ++ name ++ " to disable)" | hideDisabled]]) <>
+            mods) <|>
+       flag'
+           enabledValue
+           (hidden <> internal <> long ("enable-" ++ name) <> mods) <|>
+       flag'
+           disabledValue
+           ((if hideDisabled
+                 then hidden <> internal
+                 else idm) <>
+            long ("no-" ++ name) <>
+            help
+                (concat $ concat
+                     [ ["Disable ", helpSuffix]
+                     , [" (--no-" ++ name ++ " to enable)" | hideEnabled]]) <>
+            mods) <|>
+       flag'
+           disabledValue
+           (hidden <> internal <> long ("disable-" ++ name) <> mods)
 
 -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
 -- To actually show have that help appear, use 'execExtraHelp' before executing the main parser.