hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Support hiding commands (and parts, in theory)

pull/5/head
Lennart Spitzner 2018-01-10 00:32:08 +01:00
parent bedc74462b
commit 0f5aa00bb3
5 changed files with 118 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/UI/Butcher/Monadic/Command.hs
View File

@ -53,6 +53,7 @@
module UI.Butcher.Monadic.Command
( addCmd
, addCmdHidden
, addNullCmd
, addCmdImpl
, addCmdSynopsis

1
src/UI/Butcher/Monadic/Interactive.hs
View File

@ -129,4 +129,5 @@ partDescStrings = \case
PartReorder xs -> xs >>= partDescStrings
PartMany x -> partDescStrings x
PartWithHelp _h x -> partDescStrings x -- TODO: handle help
PartHidden{} -> []

78
src/UI/Butcher/Monadic/Internal/Core.hs
View File

@ -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
@ -1087,11 +1111,13 @@ mapOut f = hoistFree $ \case
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
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
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

20
src/UI/Butcher/Monadic/Internal/Types.hs
View File

@ -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

62
src/UI/Butcher/Monadic/Pretty.hs
View File

@ -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