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

Fix addHelpCommand to not expect a local CommandDesc

pull/5/head
Lennart Spitzner 2018-01-09 16:30:37 +01:00
parent 9f6ec52471
commit bedc74462b
1 changed files with 10 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/UI/Butcher/Monadic/BuiltinCommands.hs
View File

@ -29,19 +29,21 @@ import System.IO
-- | Adds a proper full help command. To obtain the 'CommandDesc' value, see -- | Adds a proper full help command. To obtain the 'CommandDesc' value, see
-- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or -- 'UI.Butcher.Monadic.cmdRunParserWithHelpDesc' or
-- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'. -- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'.
addHelpCommand :: Applicative f => CommandDesc () -> CmdParser f (IO ()) () addHelpCommand :: Applicative f => CommandDesc a -> CmdParser f (IO ()) ()
addHelpCommand desc = addCmd "help" $ do addHelpCommand desc = addCmd "help" $ do
rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty
addCmdImpl $ do addCmdImpl $ do
let parentDesc = maybe undefined snd (_cmd_mParent desc) let restWords = List.words rest
let restWords = List.words rest let
let descent :: [String] -> CommandDesc a -> CommandDesc a descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc descent [] curDesc = curDesc
descent (w:wr) curDesc = descent (w:wr) curDesc =
case List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc of case
List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc
of
Nothing -> curDesc Nothing -> curDesc
Just child -> descent wr child Just child -> descent wr child
print $ ppHelpShallow $ descent restWords parentDesc print $ ppHelpShallow $ descent restWords desc
-- | Adds a help command that prints help for the command currently in context. -- | Adds a help command that prints help for the command currently in context.
-- --