Support hiding flags

src/UI/Butcher/Monadic/Flag.hs

@@ -15,6 +15,7 @@ module UI.Butcher.Monadic.Flag
   , flagHelp
   , flagHelpStr
   , flagDefault
+  , flagHidden
   , addSimpleBoolFlag
   , addSimpleCountFlag
   , addSimpleFlagA
@@ -76,11 +77,17 @@ pOption m = m <|> return ()
 data Flag p = Flag
   { _flag_help       :: Maybe PP.Doc
   , _flag_default    :: Maybe p
+  , _flag_visibility :: Visibility
   }
 
 instance Monoid (Flag p) where
-  mempty = Flag Nothing Nothing
+  mempty = Flag Nothing Nothing Visible
-  Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2)
+  Flag a1 b1 c1 `mappend` Flag a2 b2 c2 = Flag (a1 <|> a2)
+                                               (b1 <|> b2)
+                                               (appVis c1 c2)
+   where
+    appVis Visible Visible = Visible
+    appVis _       _       = Hidden
 
 -- | Create a 'Flag' with just a help text.
 flagHelp :: PP.Doc -> Flag p
@@ -94,6 +101,18 @@ flagHelpStr s = mempty { _flag_help = Just $ PP.text s }
 flagDefault :: p -> Flag p
 flagDefault d = mempty { _flag_default = Just d }
 
+-- | Create a 'Flag' marked as hidden. Similar to hidden commands, hidden
+-- flags will not included in pretty-printing (help, usage etc.)
+--
+-- This feature is not well tested yet.
+flagHidden :: Flag p
+flagHidden = mempty { _flag_visibility = Hidden }
+
+wrapHidden :: Flag p -> PartDesc -> PartDesc
+wrapHidden f = case _flag_visibility f of
+  Visible -> id
+  Hidden  -> PartHidden
+
 -- | A no-parameter flag where non-occurence means False, occurence means True.
 addSimpleBoolFlag
   :: Applicative f
@@ -121,7 +140,7 @@ addSimpleBoolFlagAll
   -> f ()
   -> CmdParser f out Bool
 addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
-  $ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)
+  $ addCmdPartManyA ManyUpperBound1 (wrapHidden flag desc) parseF (\() -> a)
  where
   allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
   desc :: PartDesc
@@ -148,7 +167,7 @@ addSimpleCountFlag :: Applicative f
                    -> Flag Void -- ^ properties
                    -> CmdParser f out Int
 addSimpleCountFlag shorts longs flag = fmap length
-  $ addCmdPartMany ManyUpperBoundN desc parseF
+  $ addCmdPartMany ManyUpperBoundN (wrapHidden flag desc) parseF
  where
     -- we _could_ allow this to parse repeated short flags, like "-vvv"
     -- (meaning "-v -v -v") correctly.
@@ -179,7 +198,7 @@ addFlagReadParam
   -> Flag p -- ^ properties
   -> CmdParser f out p
 addFlagReadParam shorts longs name flag =
-  addCmdPartInpA desc parseF (\_ -> pure ())
+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@@ -261,7 +280,7 @@ addFlagReadParamsAll
      -> CmdParser f out [p]
 addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
   ManyUpperBoundN
-  desc
+  (wrapHidden flag desc)
   parseF
   act
  where
@@ -310,9 +329,8 @@ addFlagStringParam
      -> String -- ^ param name
      -> Flag String -- ^ properties
      -> CmdParser f out String
-addFlagStringParam shorts longs name flag = addCmdPartInpA desc
+addFlagStringParam shorts longs name flag =
-                                                           parseF
+  addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> pure ())
-                                                           (\_ -> pure ())
  where
   allStrs =
     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
@@ -389,7 +407,7 @@ addFlagStringParamsAll
      -> CmdParser f out [String]
 addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
   ManyUpperBoundN
-  desc
+  (wrapHidden flag desc)
   parseF
   act
  where

src/UI/Butcher/Monadic/Internal/Core.hs

@@ -221,25 +221,27 @@ addCmd
   => String -- ^ command name
   -> CmdParser f out () -- ^ subcommand
   -> CmdParser f out ()
-addCmd str sub = liftF $ CmdParserChild (Just str) sub (pure ()) Visible ()
+addCmd str sub = liftF $ CmdParserChild (Just str) Visible sub (pure ()) ()
 
 -- | Add a new child command in the current context, but make it hidden. It
 -- will not appear in docs/help generated by e.g. the functions in the
 -- @Pretty@ module.
+--
+-- This feature is not well tested yet.
 addCmdHidden
   :: Applicative f
   => String -- ^ command name
   -> CmdParser f out () -- ^ subcommand
   -> CmdParser f out ()
 addCmdHidden str sub =
-  liftF $ CmdParserChild (Just str) sub (pure ()) Hidden ()
+  liftF $ CmdParserChild (Just str) Hidden sub (pure ()) ()
 
 -- | Add a new nameless child command in the current context. Nameless means
 -- that this command matches the empty input, i.e. will always apply.
 -- This feature is experimental and CommandDesc pretty-printing might not
 -- correctly in presense of nullCmds.
 addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out ()
-addNullCmd sub = liftF $ CmdParserChild Nothing sub (pure ()) Hidden ()
+addNullCmd sub = liftF $ CmdParserChild Nothing Hidden sub (pure ()) ()
 
 -- | Add an implementation to the current command.
 addCmdImpl :: out -> CmdParser f out ()
@@ -289,7 +291,7 @@ data PartGatherData f
     }
 
 data ChildGather f out =
-  ChildGather (Maybe String) (CmdParser f out ()) (f ()) Visibility
+  ChildGather (Maybe String) Visibility (CmdParser f out ()) (f ())
 
 type PartParsedData = Map Int [Dynamic]
 
@@ -373,7 +375,7 @@ checkCmdParser mTopLevel cmdParser =
         descStack <- mGet
         mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
       processMain $ nextF monadMisuseError
-    Free (CmdParserChild cmdStr sub _act vis next) -> do
+    Free (CmdParserChild cmdStr vis sub _act next) -> do
       mInitialDesc           <- takeCommandChild cmdStr
       cmd :: CommandDesc out <- mGet
       subCmd                 <- do
@@ -651,21 +653,21 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
       let
         child_fold
           :: ( Deque (Maybe String)
-             , Map (Maybe String) (CmdParser f out (), f (), Visibility)
+             , Map (Maybe String) (Visibility, CmdParser f out (), f ())
              )
           -> ChildGather f out
           -> ( Deque (Maybe String)
-             , Map (Maybe String) (CmdParser f out (), f (), Visibility)
+             , Map (Maybe String) (Visibility, CmdParser f out (), f ())
              )
-        child_fold (c_names, c_map) (ChildGather name child act vis) =
+        child_fold (c_names, c_map) (ChildGather name vis child act) =
           case name `MapS.lookup` c_map of
             Nothing ->
               ( Deque.snoc name c_names
-              , MapS.insert name (child, act, vis) c_map
+              , MapS.insert name (vis, child, act) c_map
               )
-            Just (child', act', vis') ->
+            Just (vis', child', act') ->
               ( c_names
-              , MapS.insert name (child' >> child, act', vis') c_map
+              , MapS.insert name (vis', child' >> child, act') c_map
                  -- we intentionally override/ignore act here.
                  -- TODO: it should be documented that we expect the same act
                  -- on different child nodes with the same name.
@@ -695,7 +697,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
         Nothing -> do -- a child not matching what we have in the input
           let initialDesc :: CommandDesc out = emptyCommandDesc
           -- get the shallow desc for the child in a separate env.
-          combined_child_list `forM_` \(child_name, (child, _, vis)) -> do
+          combined_child_list `forM_` \(child_name, (vis, child, _)) -> do
             let (subCmd, subStack) =
                   runIdentity
                     $ MultiRWSS.runMultiRWSTNil
@@ -708,7 +710,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
               )
           -- proceed regularly on the same layer
           processMain $ restCmdParser
-        Just (name, child, act, vis, rest) -> do -- matching child -> descend
+        Just (name, vis, child, act, rest) -> do -- matching child -> descend
           -- process all remaining stuff on the same layer shallowly,
           -- including the current node. This will be replaced later.
           iterM processCmdShallow f
@@ -863,8 +865,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
     => CmdParser f out a
     -> m (CmdParser f out a)
   childrenGather = \case
-    Free (CmdParserChild cmdStr sub act vis next) -> do
+    Free (CmdParserChild cmdStr vis sub act next) -> do
-      mTell [ChildGather cmdStr sub act vis]
+      mTell [ChildGather cmdStr vis sub act]
       childrenGather next
     Free (CmdParserPeekInput nextF) -> do
       childrenGather $ nextF $ inputToString inputInitial
@@ -1041,7 +1043,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser =
         stackCur <- mGet
         mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
       nextF monadMisuseError
-    CmdParserChild cmdStr _sub _act vis next -> do
+    CmdParserChild cmdStr vis _sub _act next -> do
       mExisting <- takeCommandChild cmdStr
       let childDesc :: CommandDesc out =
             fromMaybe emptyCommandDesc { _cmd_visibility = vis } mExisting
@@ -1168,8 +1170,8 @@ mapOut f = hoistFree $ \case
   CmdParserPartInp desc fp fa fr -> CmdParserPartInp desc fp fa fr
   CmdParserPartManyInp bound desc fp fa fr ->
     CmdParserPartManyInp bound desc fp fa fr
-  CmdParserChild s child act vis r ->
+  CmdParserChild s vis child act r ->
-    CmdParserChild s (mapOut f child) act vis r
+    CmdParserChild s vis (mapOut f child) act r
   CmdParserImpl out r     -> CmdParserImpl (f out) r
   CmdParserReorderStart r -> CmdParserReorderStart r
   CmdParserReorderStop  r -> CmdParserReorderStop r

src/UI/Butcher/Monadic/Internal/Types.hs

@@ -73,7 +73,7 @@ data CmdParserF f out a
   | forall p . Typeable p => CmdParserPartMany ManyUpperBound PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a)
   | forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a)
   | forall p . Typeable p => CmdParserPartManyInp ManyUpperBound PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a)
-  |                          CmdParserChild (Maybe String) (CmdParser f out ()) (f ()) Visibility a
+  |                          CmdParserChild (Maybe String) Visibility (CmdParser f out ()) (f ()) a
   |                          CmdParserImpl  out                                a
   |                          CmdParserReorderStart                             a
   |                          CmdParserReorderStop                              a
@@ -146,10 +146,7 @@ data PartDesc
   | PartReorder [PartDesc]
   | PartMany PartDesc
   | PartWithHelp PP.Doc PartDesc
-  | PartHidden PartDesc -- ^ This constructor is currently unused and
+  | PartHidden PartDesc
-                        -- thus completely untested, even though some
-                        -- of the functions from @Pretty@ module are
-                        -- implemented already.
   deriving Show
 
 addSuggestion :: Maybe [String] -> PartDesc -> PartDesc