From e1c38e430f7080193c08a66b895c84a4436fac64 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 10 Jan 2018 22:39:40 +0100 Subject: [PATCH] Support hiding flags --- src/UI/Butcher/Monadic/Flag.hs | 42 +++++++++++++++++------- src/UI/Butcher/Monadic/Internal/Core.hs | 38 +++++++++++---------- src/UI/Butcher/Monadic/Internal/Types.hs | 7 ++-- 3 files changed, 52 insertions(+), 35 deletions(-) diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs index 61f2550..64b1930 100644 --- a/src/UI/Butcher/Monadic/Flag.hs +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -15,6 +15,7 @@ module UI.Butcher.Monadic.Flag , flagHelp , flagHelpStr , flagDefault + , flagHidden , addSimpleBoolFlag , addSimpleCountFlag , addSimpleFlagA @@ -74,13 +75,19 @@ pOption m = m <|> return () -- | flag-description monoid. You probably won't need to use the constructor; -- mzero or any (<>) of flag(Help|Default) works well. data Flag p = Flag - { _flag_help :: Maybe PP.Doc - , _flag_default :: Maybe p + { _flag_help :: Maybe PP.Doc + , _flag_default :: Maybe p + , _flag_visibility :: Visibility } instance Monoid (Flag p) where - mempty = Flag Nothing Nothing - Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2) + mempty = Flag Nothing Nothing Visible + 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 - parseF - (\_ -> pure ()) +addFlagStringParam shorts longs name flag = + addCmdPartInpA (wrapHidden flag desc) parseF (\_ -> 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 diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs index d5937a7..0c52434 100644 --- a/src/UI/Butcher/Monadic/Internal/Core.hs +++ b/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 - mTell [ChildGather cmdStr sub act vis] + Free (CmdParserChild cmdStr vis sub act next) -> do + 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 (mapOut f child) act vis r + CmdParserChild s vis child act r -> + CmdParserChild s vis (mapOut f child) act r CmdParserImpl out r -> CmdParserImpl (f out) r CmdParserReorderStart r -> CmdParserReorderStart r CmdParserReorderStop r -> CmdParserReorderStop r diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs index b4e152b..4153992 100644 --- a/src/UI/Butcher/Monadic/Internal/Types.hs +++ b/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 - -- thus completely untested, even though some - -- of the functions from @Pretty@ module are - -- implemented already. + | PartHidden PartDesc deriving Show addSuggestion :: Maybe [String] -> PartDesc -> PartDesc