From 0f5aa00bb3b80e02eda6dc7d8406c0c482ff73c4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 10 Jan 2018 00:32:08 +0100 Subject: [PATCH] Support hiding commands (and parts, in theory) --- src/UI/Butcher/Monadic/Command.hs | 1 + src/UI/Butcher/Monadic/Interactive.hs | 1 + src/UI/Butcher/Monadic/Internal/Core.hs | 100 ++++++++++++++--------- src/UI/Butcher/Monadic/Internal/Types.hs | 20 ++++- src/UI/Butcher/Monadic/Pretty.hs | 62 ++++++++------ 5 files changed, 118 insertions(+), 66 deletions(-) diff --git a/src/UI/Butcher/Monadic/Command.hs b/src/UI/Butcher/Monadic/Command.hs index 9af7cde..2eabfdc 100644 --- a/src/UI/Butcher/Monadic/Command.hs +++ b/src/UI/Butcher/Monadic/Command.hs @@ -53,6 +53,7 @@ module UI.Butcher.Monadic.Command ( addCmd + , addCmdHidden , addNullCmd , addCmdImpl , addCmdSynopsis diff --git a/src/UI/Butcher/Monadic/Interactive.hs b/src/UI/Butcher/Monadic/Interactive.hs index c25726a..6e95633 100644 --- a/src/UI/Butcher/Monadic/Interactive.hs +++ b/src/UI/Butcher/Monadic/Interactive.hs @@ -129,4 +129,5 @@ partDescStrings = \case PartReorder xs -> xs >>= partDescStrings PartMany x -> partDescStrings x PartWithHelp _h x -> partDescStrings x -- TODO: handle help + PartHidden{} -> [] diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs index d10e10e..1276d3d 100644 --- a/src/UI/Butcher/Monadic/Internal/Core.hs +++ b/src/UI/Butcher/Monadic/Internal/Core.hs @@ -21,6 +21,7 @@ module UI.Butcher.Monadic.Internal.Core , addCmdPartManyInp , addCmdPartManyInpA , addCmd + , addCmdHidden , addNullCmd , addCmdImpl , reorderStart @@ -216,14 +217,25 @@ addCmd => String -- ^ command name -> CmdParser f out () -- ^ subcommand -> CmdParser f out () -addCmd str sub = liftF $ CmdParserChild (Just str) sub (pure ()) () +addCmd str sub = liftF $ CmdParserChild (Just str) sub (pure ()) Visible () + +-- | 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. +addCmdHidden + :: Applicative f + => String -- ^ command name + -> CmdParser f out () -- ^ subcommand + -> CmdParser f out () +addCmdHidden str sub = + liftF $ CmdParserChild (Just str) sub (pure ()) Hidden () -- | 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 ()) () +addNullCmd sub = liftF $ CmdParserChild Nothing sub (pure ()) Hidden () -- | Add an implementation to the current command. addCmdImpl :: out -> CmdParser f out () @@ -272,7 +284,8 @@ data PartGatherData f , _pgd_many :: Bool } -data ChildGather f out = ChildGather (Maybe String) (CmdParser f out ()) (f ()) +data ChildGather f out = + ChildGather (Maybe String) (CmdParser f out ()) (f ()) Visibility type PartParsedData = Map Int [Dynamic] @@ -350,7 +363,7 @@ checkCmdParser mTopLevel cmdParser descStack <- mGet mSet $ descStackAdd (wrapBoundDesc bound desc) descStack processMain $ nextF monadMisuseError - Free (CmdParserChild cmdStr sub _act next) -> do + Free (CmdParserChild cmdStr sub _act vis next) -> do mInitialDesc <- takeCommandChild cmdStr cmd :: CommandDesc out <- mGet subCmd <- do @@ -365,7 +378,7 @@ checkCmdParser mTopLevel cmdParser subParts <- case stackBelow of StackBottom descs -> return $ Data.Foldable.toList descs StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart" - return c { _cmd_parts = subParts } + return c { _cmd_parts = subParts, _cmd_visibility = vis } mSet $ cmd { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd } @@ -600,25 +613,29 @@ runCmdParserAExt mTopLevel inputInitial cmdParser r <- proc let act = traverse actF r (act *>) <$> processMain (nextF $ r) - f@(Free (CmdParserChild _ _ _ _)) -> do + f@(Free (CmdParserChild _ _ _ _ _)) -> do dropSpaces input <- mGet (gatheredChildren :: [ChildGather f out], restCmdParser) <- MultiRWSS.withMultiWriterWA $ childrenGather f let child_fold - :: (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ())) + :: ( Deque (Maybe String) + , Map (Maybe String) (CmdParser f out (), f (), Visibility) + ) -> ChildGather f out - -> (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ())) - child_fold (c_names, c_map) (ChildGather name child act) = + -> ( Deque (Maybe String) + , Map (Maybe String) (CmdParser f out (), f (), Visibility) + ) + child_fold (c_names, c_map) (ChildGather name child act vis) = case name `MapS.lookup` c_map of Nothing -> ( Deque.snoc name c_names - , MapS.insert name (child, act) c_map + , MapS.insert name (child, act, vis) c_map ) - Just (child', act') -> + Just (child', act', vis') -> ( c_names - , MapS.insert name (child' >> child, act') c_map + , MapS.insert name (child' >> child, act', vis') 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. @@ -627,32 +644,36 @@ runCmdParserAExt mTopLevel inputInitial cmdParser foldl' child_fold (mempty, MapS.empty) gatheredChildren combined_child_list = Data.Foldable.toList child_name_list <&> \n -> (n, child_map MapS.! n) - let mRest = asum $ combined_child_list <&> \(mname, (child, act)) -> + let mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) -> case (mname, input) of (Just name, InputString str) | name == str -> - Just $ (Just name, child, act, InputString "") + Just $ (Just name, child, act, vis, InputString "") (Just name, InputString str) | (name++" ") `isPrefixOf` str -> - Just $ (Just name, child, act, InputString $ drop (length name + 1) str) + Just $ (Just name, child, act, vis, InputString $ drop (length name + 1) str) (Just name, InputArgs (str:strr)) | name == str -> - Just $ (Just name, child, act, InputArgs strr) + Just $ (Just name, child, act, vis, InputArgs strr) (Nothing, _) -> - Just $ (Nothing, child, act, input) + Just $ (Nothing, child, act, vis, input) _ -> Nothing case mRest of 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, _)) -> do + combined_child_list `forM_` \(child_name, (child, _, vis)) -> do let (subCmd, subStack) = runIdentity $ MultiRWSS.runMultiRWSTNil $ MultiRWSS.withMultiStateSA initialDesc $ MultiRWSS.withMultiStateS (StackBottom mempty) $ iterM processCmdShallow child - cmd_children %=+ Deque.snoc (child_name, postProcessCmd subStack subCmd) + cmd_children + %=+ Deque.snoc + ( child_name + , postProcessCmd subStack subCmd{_cmd_visibility = vis} + ) -- proceed regularly on the same layer processMain $ restCmdParser - Just (name, child, act, rest) -> do -- matching child -> descend + Just (name, child, act, vis, 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 @@ -665,6 +686,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser mSet $ PastCommandInput rest mSet $ emptyCommandDesc { _cmd_mParent = Just (name, cmd) + , _cmd_visibility = vis } mSet $ child mSet $ StackBottom mempty @@ -799,8 +821,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser => CmdParser f out a -> m (CmdParser f out a) childrenGather = \case - Free (CmdParserChild cmdStr sub act next) -> do - mTell [ChildGather cmdStr sub act] + Free (CmdParserChild cmdStr sub act vis next) -> do + mTell [ChildGather cmdStr sub act vis] childrenGather next Free (CmdParserPeekInput nextF) -> do childrenGather $ nextF $ inputToString inputInitial @@ -970,9 +992,10 @@ runCmdParserAExt mTopLevel inputInitial cmdParser stackCur <- mGet mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur nextF monadMisuseError - CmdParserChild cmdStr _sub _act next -> do + CmdParserChild cmdStr _sub _act vis next -> do mExisting <- takeCommandChild cmdStr - let childDesc :: CommandDesc out = fromMaybe emptyCommandDesc mExisting + let childDesc :: CommandDesc out = + fromMaybe emptyCommandDesc {_cmd_visibility = vis} mExisting cmd_children %=+ Deque.snoc (cmdStr, childDesc) next CmdParserImpl out next -> do @@ -1046,6 +1069,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser PartWithHelp _ d -> f d PartSeq ds -> List.unwords $ f <$> ds PartReorder ds -> List.unwords $ f <$> ds + PartHidden d -> f d where f = getPartSeqDescPositionName @@ -1082,21 +1106,23 @@ takeCommandChild key = do -- | map over the @out@ type argument mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb () mapOut f = hoistFree $ \case - CmdParserHelp doc r -> CmdParserHelp doc r - CmdParserSynopsis s r -> CmdParserSynopsis s r - CmdParserPeekDesc fr -> CmdParserPeekDesc fr - CmdParserPeekInput fr -> CmdParserPeekInput fr - CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa fr - CmdParserPartMany bound desc fp fa fr -> CmdParserPartMany bound desc fp fa fr - CmdParserPartInp desc fp fa fr -> CmdParserPartInp desc fp fa fr + CmdParserHelp doc r -> CmdParserHelp doc r + CmdParserSynopsis s r -> CmdParserSynopsis s r + CmdParserPeekDesc fr -> CmdParserPeekDesc fr + CmdParserPeekInput fr -> CmdParserPeekInput fr + CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa fr + CmdParserPartMany bound desc fp fa fr -> + CmdParserPartMany bound desc fp fa fr + 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 r -> CmdParserChild s (mapOut f child) act r - CmdParserImpl out r -> CmdParserImpl (f out) r - CmdParserReorderStart r -> CmdParserReorderStart r - CmdParserReorderStop r -> CmdParserReorderStop r - CmdParserGrouped s r -> CmdParserGrouped s r - CmdParserGroupEnd r -> CmdParserGroupEnd r + CmdParserChild s child act vis r -> + CmdParserChild s (mapOut f child) act vis r + CmdParserImpl out r -> CmdParserImpl (f out) r + CmdParserReorderStart r -> CmdParserReorderStart r + CmdParserReorderStop r -> CmdParserReorderStop r + CmdParserGrouped s r -> CmdParserGrouped s r + CmdParserGroupEnd r -> CmdParserGroupEnd r -- cmdActionPartial :: CommandDesc out -> Either String out -- cmdActionPartial = maybe (Left err) Right . _cmd_out diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs index a50d0dc..b4e152b 100644 --- a/src/UI/Butcher/Monadic/Internal/Types.hs +++ b/src/UI/Butcher/Monadic/Internal/Types.hs @@ -13,6 +13,7 @@ module UI.Butcher.Monadic.Internal.Types , cmd_parts , cmd_out , cmd_children + , cmd_visibility , emptyCommandDesc , CmdParserF (..) , CmdParser @@ -21,6 +22,7 @@ module UI.Butcher.Monadic.Internal.Types , ParsingError (..) , addSuggestion , ManyUpperBound (..) + , Visibility (..) ) where @@ -57,6 +59,9 @@ data ManyUpperBound = ManyUpperBound1 | ManyUpperBoundN +data Visibility = Visible | Hidden + deriving (Show, Eq) + data CmdParserF f out a = CmdParserHelp PP.Doc a | CmdParserSynopsis String a @@ -68,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 ()) a + | CmdParserChild (Maybe String) (CmdParser f out ()) (f ()) Visibility a | CmdParserImpl out a | CmdParserReorderStart a | CmdParserReorderStop a @@ -117,6 +122,7 @@ data CommandDesc out = CommandDesc , _cmd_children :: Deque (Maybe String, CommandDesc out) -- we don't use a Map here because we'd like to -- retain the order. + , _cmd_visibility :: Visibility } -- type PartSeqDesc = [PartDesc] @@ -140,6 +146,10 @@ 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. deriving Show addSuggestion :: Maybe [String] -> PartDesc -> PartDesc @@ -168,7 +178,8 @@ deriving instance Functor CommandDesc -- emptyCommandDesc :: CommandDesc out -emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty +emptyCommandDesc = + CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible instance Show (CommandDesc out) where show c = "Command help=" ++ show (_cmd_help c) @@ -208,3 +219,8 @@ LensTH.makeLenses ''PartDesc -- show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")" -- show (CmdParserRun _) = "CmdParserRun" +instance Alternative Deque where + empty = mempty + (<|>) = Deque.prepend + +instance MonadPlus Deque diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs index b93420a..692737e 100644 --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -58,14 +58,14 @@ import UI.Butcher.Monadic.Internal.Core -- -- > example [--short] NAME [version | help] ppUsage :: CommandDesc a -> PP.Doc -ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent - <+> PP.sep [PP.fsep partDocs, subsDoc] +ppUsage (CommandDesc mParent _syn _help parts out children _hidden) = + pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc] where pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc pparents Nothing = PP.empty pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - partDocs = parts <&> ppPartDescUsage + partDocs = Maybe.mapMaybe ppPartDescUsage parts subsDoc = case out of _ | null children -> PP.empty -- TODO: remove debug Nothing | null parts -> subDoc @@ -75,7 +75,7 @@ ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent PP.fcat $ PP.punctuate (PP.text " | ") $ Data.Foldable.toList - $ [ PP.text n | (Just n, _) <- children ] + $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ] -- | ppUsageWithHelp exampleDesc yields: -- @@ -84,14 +84,14 @@ ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent -- -- And yes, the line break is not optimal in this instance with default print. ppUsageWithHelp :: CommandDesc a -> PP.Doc -ppUsageWithHelp (CommandDesc mParent _syn help parts out children) = +ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) = pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc where pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc pparents Nothing = PP.empty pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) - partDocs = parts <&> ppPartDescUsage + partDocs = Maybe.mapMaybe ppPartDescUsage parts subsDoc = case out of _ | null children -> PP.empty -- TODO: remove debug Nothing | null parts -> subDoc @@ -101,7 +101,7 @@ ppUsageWithHelp (CommandDesc mParent _syn help parts out children) = PP.fcat $ PP.punctuate (PP.text " | ") $ Data.Foldable.toList - $ [ PP.text n | (Just n, _) <- children ] + $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ] helpDoc = case help of Nothing -> PP.empty Just h -> PP.text ":" PP.<+> h @@ -138,13 +138,14 @@ ppUsageAt strings desc = -- > --short make the greeting short -- > NAME your name, so you can be greeted properly ppHelpShallow :: CommandDesc a -> PP.Doc -ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = +ppHelpShallow desc = nameSection $+$ usageSection $+$ descriptionSection $+$ partsSection $+$ PP.text "" where + CommandDesc mParent syn help parts _out _children _hidden = desc nameSection = case mParent of Nothing -> PP.empty Just{} -> @@ -183,24 +184,30 @@ ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = PartDefault _ p -> go p PartSuggestion _ p -> go p PartRedirect s p -> - [PP.text s $$ PP.nest 20 (ppPartDescUsage p)] ++ (PP.nest 2 <$> go p) + [PP.text s $$ PP.nest 20 (fromMaybe PP.empty $ ppPartDescUsage p)] + ++ (PP.nest 2 <$> go p) PartReorder ps -> ps >>= go PartMany p -> go p PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p + PartHidden{} -> [] -- | Internal helper; users probably won't need this. -ppPartDescUsage :: PartDesc -> PP.Doc +ppPartDescUsage :: PartDesc -> Maybe PP.Doc ppPartDescUsage = \case - PartLiteral s -> PP.text s - PartVariable s -> PP.text s - PartOptional p -> PP.brackets $ rec p - PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps - PartSeq ps -> PP.fsep $ rec <$> ps - PartDefault _ p -> PP.brackets $ rec p - PartSuggestion s p -> - PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [rec p] - PartRedirect s _ -> PP.text s - PartMany p -> rec p <> PP.text "+" + PartLiteral s -> Just $ PP.text s + PartVariable s -> Just $ PP.text s + PartOptional p -> PP.brackets <$> rec p + PartAlts ps -> + [ PP.fcat $ PP.punctuate (PP.text ",") ds + | let ds = Maybe.mapMaybe rec ps + , not (null ds) + ] + PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ] + PartDefault _ p -> PP.brackets <$> rec p + PartSuggestion s p -> rec p <&> \d -> + PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [d] + PartRedirect s _ -> Just $ PP.text s + PartMany p -> rec p <&> (<> PP.text "+") PartWithHelp _ p -> rec p PartReorder ps -> let flags = [ d | PartMany d <- ps ] @@ -210,11 +217,12 @@ ppPartDescUsage = \case _ -> True ) ps - in PP.sep - [(PP.fsep $ PP.brackets . rec <$> flags), PP.fsep (rec <$> params)] - - where - rec = ppPartDescUsage + in Just $ PP.sep + [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags) + , PP.fsep (Maybe.mapMaybe rec params) + ] + PartHidden{} -> Nothing + where rec = ppPartDescUsage -- | Internal helper; users probably won't need this. ppPartDescHeader :: PartDesc -> PP.Doc @@ -230,8 +238,8 @@ ppPartDescHeader = \case PartWithHelp _ d -> rec d PartSeq ds -> PP.hsep $ rec <$> ds PartReorder ds -> PP.vcat $ rec <$> ds - where - rec = ppPartDescHeader + PartHidden d -> rec d + where rec = ppPartDescHeader -- | Simple conversion from 'ParsingError' to 'String'. parsingErrorString :: ParsingError -> String