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 module UI.Butcher.Monadic.Command
( addCmd ( addCmd
, addCmdHidden
, addNullCmd , addNullCmd
, addCmdImpl , addCmdImpl
, addCmdSynopsis , addCmdSynopsis

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

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

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

@ -21,6 +21,7 @@ module UI.Butcher.Monadic.Internal.Core
, addCmdPartManyInp , addCmdPartManyInp
, addCmdPartManyInpA , addCmdPartManyInpA
, addCmd , addCmd
, addCmdHidden
, addNullCmd , addNullCmd
, addCmdImpl , addCmdImpl
, reorderStart , reorderStart
@ -216,14 +217,25 @@ addCmd
=> String -- ^ command name => String -- ^ command name
-> CmdParser f out () -- ^ subcommand -> CmdParser f out () -- ^ subcommand
-> CmdParser f out () -> 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 -- | Add a new nameless child command in the current context. Nameless means
-- that this command matches the empty input, i.e. will always apply. -- that this command matches the empty input, i.e. will always apply.
-- This feature is experimental and CommandDesc pretty-printing might not -- This feature is experimental and CommandDesc pretty-printing might not
-- correctly in presense of nullCmds. -- correctly in presense of nullCmds.
addNullCmd :: Applicative f => CmdParser f out () -> CmdParser f out () 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. -- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out () addCmdImpl :: out -> CmdParser f out ()
@ -272,7 +284,8 @@ data PartGatherData f
, _pgd_many :: Bool , _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] type PartParsedData = Map Int [Dynamic]
@ -350,7 +363,7 @@ checkCmdParser mTopLevel cmdParser
descStack <- mGet descStack <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) descStack mSet $ descStackAdd (wrapBoundDesc bound desc) descStack
processMain $ nextF monadMisuseError processMain $ nextF monadMisuseError
Free (CmdParserChild cmdStr sub _act next) -> do Free (CmdParserChild cmdStr sub _act vis next) -> do
mInitialDesc <- takeCommandChild cmdStr mInitialDesc <- takeCommandChild cmdStr
cmd :: CommandDesc out <- mGet cmd :: CommandDesc out <- mGet
subCmd <- do subCmd <- do
@ -365,7 +378,7 @@ checkCmdParser mTopLevel cmdParser
subParts <- case stackBelow of subParts <- case stackBelow of
StackBottom descs -> return $ Data.Foldable.toList descs StackBottom descs -> return $ Data.Foldable.toList descs
StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart" StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart"
return c { _cmd_parts = subParts } return c { _cmd_parts = subParts, _cmd_visibility = vis }
mSet $ cmd mSet $ cmd
{ _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd { _cmd_children = (cmdStr, subCmd) `Deque.snoc` _cmd_children cmd
} }
@ -600,25 +613,29 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
r <- proc r <- proc
let act = traverse actF r let act = traverse actF r
(act *>) <$> processMain (nextF $ r) (act *>) <$> processMain (nextF $ r)
f@(Free (CmdParserChild _ _ _ _)) -> do f@(Free (CmdParserChild _ _ _ _ _)) -> do
dropSpaces dropSpaces
input <- mGet input <- mGet
(gatheredChildren :: [ChildGather f out], restCmdParser) <- (gatheredChildren :: [ChildGather f out], restCmdParser) <-
MultiRWSS.withMultiWriterWA $ childrenGather f MultiRWSS.withMultiWriterWA $ childrenGather f
let let
child_fold 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 -> ChildGather f out
-> (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ())) -> ( Deque (Maybe String)
child_fold (c_names, c_map) (ChildGather name child act) = , 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 case name `MapS.lookup` c_map of
Nothing -> Nothing ->
( Deque.snoc name c_names ( 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 ( 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. -- we intentionally override/ignore act here.
-- TODO: it should be documented that we expect the same act -- TODO: it should be documented that we expect the same act
-- on different child nodes with the same name. -- on different child nodes with the same name.
@ -627,32 +644,36 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
foldl' child_fold (mempty, MapS.empty) gatheredChildren foldl' child_fold (mempty, MapS.empty) gatheredChildren
combined_child_list = Data.Foldable.toList child_name_list <&> \n -> combined_child_list = Data.Foldable.toList child_name_list <&> \n ->
(n, child_map MapS.! 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 case (mname, input) of
(Just name, InputString str) | name == str -> (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 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 name, InputArgs (str:strr)) | name == str ->
Just $ (Just name, child, act, InputArgs strr) Just $ (Just name, child, act, vis, InputArgs strr)
(Nothing, _) -> (Nothing, _) ->
Just $ (Nothing, child, act, input) Just $ (Nothing, child, act, vis, input)
_ -> Nothing _ -> Nothing
case mRest of case mRest of
Nothing -> do -- a child not matching what we have in the input Nothing -> do -- a child not matching what we have in the input
let initialDesc :: CommandDesc out = emptyCommandDesc let initialDesc :: CommandDesc out = emptyCommandDesc
-- get the shallow desc for the child in a separate env. -- 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) let (subCmd, subStack)
= runIdentity = runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateSA initialDesc $ MultiRWSS.withMultiStateSA initialDesc
$ MultiRWSS.withMultiStateS (StackBottom mempty) $ MultiRWSS.withMultiStateS (StackBottom mempty)
$ iterM processCmdShallow child $ 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 -- proceed regularly on the same layer
processMain $ restCmdParser 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, -- process all remaining stuff on the same layer shallowly,
-- including the current node. This will be replaced later. -- including the current node. This will be replaced later.
iterM processCmdShallow f iterM processCmdShallow f
@ -665,6 +686,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
mSet $ PastCommandInput rest mSet $ PastCommandInput rest
mSet $ emptyCommandDesc mSet $ emptyCommandDesc
{ _cmd_mParent = Just (name, cmd) { _cmd_mParent = Just (name, cmd)
, _cmd_visibility = vis
} }
mSet $ child mSet $ child
mSet $ StackBottom mempty mSet $ StackBottom mempty
@ -799,8 +821,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
=> CmdParser f out a => CmdParser f out a
-> m (CmdParser f out a) -> m (CmdParser f out a)
childrenGather = \case childrenGather = \case
Free (CmdParserChild cmdStr sub act next) -> do Free (CmdParserChild cmdStr sub act vis next) -> do
mTell [ChildGather cmdStr sub act] mTell [ChildGather cmdStr sub act vis]
childrenGather next childrenGather next
Free (CmdParserPeekInput nextF) -> do Free (CmdParserPeekInput nextF) -> do
childrenGather $ nextF $ inputToString inputInitial childrenGather $ nextF $ inputToString inputInitial
@ -970,9 +992,10 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
stackCur <- mGet stackCur <- mGet
mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur mSet $ descStackAdd (wrapBoundDesc bound desc) stackCur
nextF monadMisuseError nextF monadMisuseError
CmdParserChild cmdStr _sub _act next -> do CmdParserChild cmdStr _sub _act vis next -> do
mExisting <- takeCommandChild cmdStr 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) cmd_children %=+ Deque.snoc (cmdStr, childDesc)
next next
CmdParserImpl out next -> do CmdParserImpl out next -> do
@ -1046,6 +1069,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
PartWithHelp _ d -> f d PartWithHelp _ d -> f d
PartSeq ds -> List.unwords $ f <$> ds PartSeq ds -> List.unwords $ f <$> ds
PartReorder ds -> List.unwords $ f <$> ds PartReorder ds -> List.unwords $ f <$> ds
PartHidden d -> f d
where where
f = getPartSeqDescPositionName f = getPartSeqDescPositionName
@ -1082,21 +1106,23 @@ takeCommandChild key = do
-- | map over the @out@ type argument -- | map over the @out@ type argument
mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb () mapOut :: (outa -> outb) -> CmdParser f outa () -> CmdParser f outb ()
mapOut f = hoistFree $ \case mapOut f = hoistFree $ \case
CmdParserHelp doc r -> CmdParserHelp doc r CmdParserHelp doc r -> CmdParserHelp doc r
CmdParserSynopsis s r -> CmdParserSynopsis s r CmdParserSynopsis s r -> CmdParserSynopsis s r
CmdParserPeekDesc fr -> CmdParserPeekDesc fr CmdParserPeekDesc fr -> CmdParserPeekDesc fr
CmdParserPeekInput fr -> CmdParserPeekInput fr CmdParserPeekInput fr -> CmdParserPeekInput fr
CmdParserPart desc fp fa fr -> CmdParserPart desc fp fa 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 ->
CmdParserPartInp desc fp fa fr -> CmdParserPartInp 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 ->
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 ->
CmdParserImpl out r -> CmdParserImpl (f out) r CmdParserChild s (mapOut f child) act vis r
CmdParserReorderStart r -> CmdParserReorderStart r CmdParserImpl out r -> CmdParserImpl (f out) r
CmdParserReorderStop r -> CmdParserReorderStop r CmdParserReorderStart r -> CmdParserReorderStart r
CmdParserGrouped s r -> CmdParserGrouped s r CmdParserReorderStop r -> CmdParserReorderStop r
CmdParserGroupEnd r -> CmdParserGroupEnd r CmdParserGrouped s r -> CmdParserGrouped s r
CmdParserGroupEnd r -> CmdParserGroupEnd r
-- cmdActionPartial :: CommandDesc out -> Either String out -- cmdActionPartial :: CommandDesc out -> Either String out
-- cmdActionPartial = maybe (Left err) Right . _cmd_out -- cmdActionPartial = maybe (Left err) Right . _cmd_out

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

@ -13,6 +13,7 @@ module UI.Butcher.Monadic.Internal.Types
, cmd_parts , cmd_parts
, cmd_out , cmd_out
, cmd_children , cmd_children
, cmd_visibility
, emptyCommandDesc , emptyCommandDesc
, CmdParserF (..) , CmdParserF (..)
, CmdParser , CmdParser
@ -21,6 +22,7 @@ module UI.Butcher.Monadic.Internal.Types
, ParsingError (..) , ParsingError (..)
, addSuggestion , addSuggestion
, ManyUpperBound (..) , ManyUpperBound (..)
, Visibility (..)
) )
where where
@ -57,6 +59,9 @@ data ManyUpperBound
= ManyUpperBound1 = ManyUpperBound1
| ManyUpperBoundN | ManyUpperBoundN
data Visibility = Visible | Hidden
deriving (Show, Eq)
data CmdParserF f out a data CmdParserF f out a
= CmdParserHelp PP.Doc a = CmdParserHelp PP.Doc a
| CmdParserSynopsis String 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 => 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 => 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) | 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 | CmdParserImpl out a
| CmdParserReorderStart a | CmdParserReorderStart a
| CmdParserReorderStop a | CmdParserReorderStop a
@ -117,6 +122,7 @@ data CommandDesc out = CommandDesc
, _cmd_children :: Deque (Maybe String, CommandDesc out) , _cmd_children :: Deque (Maybe String, CommandDesc out)
-- we don't use a Map here because we'd like to -- we don't use a Map here because we'd like to
-- retain the order. -- retain the order.
, _cmd_visibility :: Visibility
} }
-- type PartSeqDesc = [PartDesc] -- type PartSeqDesc = [PartDesc]
@ -140,6 +146,10 @@ data PartDesc
| PartReorder [PartDesc] | PartReorder [PartDesc]
| PartMany PartDesc | PartMany PartDesc
| PartWithHelp PP.Doc 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 deriving Show
addSuggestion :: Maybe [String] -> PartDesc -> PartDesc addSuggestion :: Maybe [String] -> PartDesc -> PartDesc
@ -168,7 +178,8 @@ deriving instance Functor CommandDesc
-- --
emptyCommandDesc :: CommandDesc out emptyCommandDesc :: CommandDesc out
emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing mempty emptyCommandDesc =
CommandDesc Nothing Nothing Nothing [] Nothing mempty Visible
instance Show (CommandDesc out) where instance Show (CommandDesc out) where
show c = "Command help=" ++ show (_cmd_help c) show c = "Command help=" ++ show (_cmd_help c)
@ -208,3 +219,8 @@ LensTH.makeLenses ''PartDesc
-- show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")" -- show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")"
-- show (CmdParserRun _) = "CmdParserRun" -- 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] -- > example [--short] NAME [version | help]
ppUsage :: CommandDesc a -> PP.Doc ppUsage :: CommandDesc a -> PP.Doc
ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =
<+> PP.sep [PP.fsep partDocs, subsDoc] pparents mParent <+> PP.sep [PP.fsep partDocs, subsDoc]
where where
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
partDocs = parts <&> ppPartDescUsage partDocs = Maybe.mapMaybe ppPartDescUsage parts
subsDoc = case out of subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug _ | null children -> PP.empty -- TODO: remove debug
Nothing | null parts -> subDoc Nothing | null parts -> subDoc
@ -75,7 +75,7 @@ ppUsage (CommandDesc mParent _syn _help parts out children) = pparents mParent
PP.fcat PP.fcat
$ PP.punctuate (PP.text " | ") $ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList $ Data.Foldable.toList
$ [ PP.text n | (Just n, _) <- children ] $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
-- | ppUsageWithHelp exampleDesc yields: -- | 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. -- And yes, the line break is not optimal in this instance with default print.
ppUsageWithHelp :: CommandDesc a -> PP.Doc 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 pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
where where
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) <+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd) pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
partDocs = parts <&> ppPartDescUsage partDocs = Maybe.mapMaybe ppPartDescUsage parts
subsDoc = case out of subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug _ | null children -> PP.empty -- TODO: remove debug
Nothing | null parts -> subDoc Nothing | null parts -> subDoc
@ -101,7 +101,7 @@ ppUsageWithHelp (CommandDesc mParent _syn help parts out children) =
PP.fcat PP.fcat
$ PP.punctuate (PP.text " | ") $ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList $ Data.Foldable.toList
$ [ PP.text n | (Just n, _) <- children ] $ [ PP.text n | (Just n, c) <- children, _cmd_visibility c == Visible ]
helpDoc = case help of helpDoc = case help of
Nothing -> PP.empty Nothing -> PP.empty
Just h -> PP.text ":" PP.<+> h Just h -> PP.text ":" PP.<+> h
@ -138,13 +138,14 @@ ppUsageAt strings desc =
-- > --short make the greeting short -- > --short make the greeting short
-- > NAME your name, so you can be greeted properly -- > NAME your name, so you can be greeted properly
ppHelpShallow :: CommandDesc a -> PP.Doc ppHelpShallow :: CommandDesc a -> PP.Doc
ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = ppHelpShallow desc =
nameSection nameSection
$+$ usageSection $+$ usageSection
$+$ descriptionSection $+$ descriptionSection
$+$ partsSection $+$ partsSection
$+$ PP.text "" $+$ PP.text ""
where where
CommandDesc mParent syn help parts _out _children _hidden = desc
nameSection = case mParent of nameSection = case mParent of
Nothing -> PP.empty Nothing -> PP.empty
Just{} -> Just{} ->
@ -183,24 +184,30 @@ ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) =
PartDefault _ p -> go p PartDefault _ p -> go p
PartSuggestion _ p -> go p PartSuggestion _ p -> go p
PartRedirect s 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 PartReorder ps -> ps >>= go
PartMany p -> go p PartMany p -> go p
PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ go p
PartHidden{} -> []
-- | Internal helper; users probably won't need this. -- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> PP.Doc ppPartDescUsage :: PartDesc -> Maybe PP.Doc
ppPartDescUsage = \case ppPartDescUsage = \case
PartLiteral s -> PP.text s PartLiteral s -> Just $ PP.text s
PartVariable s -> PP.text s PartVariable s -> Just $ PP.text s
PartOptional p -> PP.brackets $ rec p PartOptional p -> PP.brackets <$> rec p
PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps PartAlts ps ->
PartSeq ps -> PP.fsep $ rec <$> ps [ PP.fcat $ PP.punctuate (PP.text ",") ds
PartDefault _ p -> PP.brackets $ rec p | let ds = Maybe.mapMaybe rec ps
PartSuggestion s p -> , not (null ds)
PP.parens $ PP.fcat $ PP.punctuate (PP.text "|") $ fmap PP.text s ++ [rec p] ]
PartRedirect s _ -> PP.text s PartSeq ps -> [ PP.fsep ds | let ds = Maybe.mapMaybe rec ps, not (null ds) ]
PartMany p -> rec p <> PP.text "+" 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 PartWithHelp _ p -> rec p
PartReorder ps -> PartReorder ps ->
let flags = [ d | PartMany d <- ps ] let flags = [ d | PartMany d <- ps ]
@ -210,11 +217,12 @@ ppPartDescUsage = \case
_ -> True _ -> True
) )
ps ps
in PP.sep in Just $ PP.sep
[(PP.fsep $ PP.brackets . rec <$> flags), PP.fsep (rec <$> params)] [ (PP.fsep $ PP.brackets <$> Maybe.mapMaybe rec flags)
, PP.fsep (Maybe.mapMaybe rec params)
where ]
rec = ppPartDescUsage PartHidden{} -> Nothing
where rec = ppPartDescUsage
-- | Internal helper; users probably won't need this. -- | Internal helper; users probably won't need this.
ppPartDescHeader :: PartDesc -> PP.Doc ppPartDescHeader :: PartDesc -> PP.Doc
@ -230,8 +238,8 @@ ppPartDescHeader = \case
PartWithHelp _ d -> rec d PartWithHelp _ d -> rec d
PartSeq ds -> PP.hsep $ rec <$> ds PartSeq ds -> PP.hsep $ rec <$> ds
PartReorder ds -> PP.vcat $ rec <$> ds PartReorder ds -> PP.vcat $ rec <$> ds
where PartHidden d -> rec d
rec = ppPartDescHeader where rec = ppPartDescHeader
-- | Simple conversion from 'ParsingError' to 'String'. -- | Simple conversion from 'ParsingError' to 'String'.
parsingErrorString :: ParsingError -> String parsingErrorString :: ParsingError -> String