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

Add `addNullCmd` and `addStringParams`

pull/5/head
Lennart Spitzner 2017-10-02 22:45:43 +02:00
parent b7f1f0382f
commit 95886b898b
7 changed files with 144 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src-tests/TestMain.hs
View File

@ -103,7 +103,13 @@ simpleRunTest = do
it "flag 6" $ testRun testCmd5 "abc -f" `shouldSatisfy` Data.Either.isLeft
it "flag 6" $ testRun testCmd5 "abc -flag 0" `shouldSatisfy` Data.Either.isLeft
it "flag 6" $ testRun testCmd5 "abc --f 0" `shouldSatisfy` Data.Either.isLeft
describe "addStringParams" $ do
it "case 1" $ testRun' testCmd6 "" `shouldBe` Right (Just ([], 0))
it "case 2" $ testRun' testCmd6 "-f" `shouldBe` Right (Just ([], 1))
it "case 3" $ testRun' testCmd6 "abc" `shouldBe` Right (Just (["abc"], 0))
it "case 4" $ testRun' testCmd6 "abc def" `shouldBe` Right (Just (["abc", "def"], 0))
it "case 5" $ testRun' testCmd6 "-g abc def" `shouldBe` Right (Just (["abc", "def"], 2))
it "case 6" $ testRun' testCmd6 "-f -g def" `shouldBe` Right (Just (["def"], 3))
@ -167,6 +173,16 @@ testCmd5 = do
x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int))
addCmdImpl $ WriterS.tell (Sum x)
testCmd6 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
testCmd6 = do
f <- addSimpleBoolFlag "f" ["flong"] mempty
g <- addSimpleBoolFlag "g" ["glong"] mempty
args <- addStringParams "ARGS" mempty
addCmdImpl $ do
when f $ WriterS.tell 1
when g $ WriterS.tell 2
pure args
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just
@ -178,6 +194,13 @@ testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out)
$ snd
$ runCmdParser Nothing (InputString s) cmd
testRun' :: CmdParser Identity (WriterS.Writer (Sum Int) a) () -> String -> Either ParsingError (Maybe (a, Int))
testRun' cmd s =
fmap (fmap (fmap getSum . WriterS.runWriter) . _cmd_out) $ snd $ runCmdParser
Nothing
(InputString s)
cmd
testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int
testRunA cmd str = (\((_, e), s) -> e $> s)
$ flip StateS.runState (0::Int)

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

@ -38,7 +38,7 @@ addHelpCommand desc = addCmd "help" $ do
let descent :: [String] -> CommandDesc a -> CommandDesc a
descent [] curDesc = curDesc
descent (w:wr) curDesc =
case List.lookup w $ Data.Foldable.toList $ _cmd_children curDesc of
case List.lookup (Just w) $ Data.Foldable.toList $ _cmd_children curDesc of
Nothing -> curDesc
Just child -> descent wr child
print $ ppHelpShallow $ descent restWords parentDesc

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

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

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

@ -21,6 +21,7 @@ module UI.Butcher.Monadic.Internal.Core
, addCmdPartManyInp
, addCmdPartManyInpA
, addCmd
, addNullCmd
, addCmdImpl
, reorderStart
, reorderStop
@ -215,7 +216,14 @@ addCmd
=> String -- ^ command name
-> CmdParser f out () -- ^ subcommand
-> CmdParser f out ()
addCmd str sub = liftF $ CmdParserChild str sub (pure ()) ()
addCmd str sub = liftF $ CmdParserChild (Just str) 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 ()) ()
-- | Add an implementation to the current command.
addCmdImpl :: out -> CmdParser f out ()
@ -264,7 +272,7 @@ data PartGatherData f
, _pgd_many :: Bool
}
data ChildGather f out = ChildGather String (CmdParser f out ()) (f ())
data ChildGather f out = ChildGather (Maybe String) (CmdParser f out ()) (f ())
type PartParsedData = Map Int [Dynamic]
@ -301,7 +309,7 @@ checkCmdParser mTopLevel cmdParser
final (desc, stack)
= case stack of
StackBottom descs -> Right
$ descFixParentsWithTopM (mTopLevel <&> \n -> (n, emptyCommandDesc))
$ descFixParentsWithTopM (mTopLevel <&> \n -> (Just n, emptyCommandDesc))
$ () <$ desc
{ _cmd_parts = Data.Foldable.toList descs
}
@ -461,7 +469,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
$ processMain cmdParser
where
initialCommandDesc = emptyCommandDesc
{ _cmd_mParent = mTopLevel <&> \n -> (n, emptyCommandDesc) }
{ _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc) }
captureFinal
:: ([String], (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f())))))
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
@ -599,9 +607,9 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
MultiRWSS.withMultiWriterWA $ childrenGather f
let
child_fold
:: (Deque String, Map String (CmdParser f out (), f ()))
:: (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ()))
-> ChildGather f out
-> (Deque String, Map String (CmdParser f out (), f ()))
-> (Deque (Maybe String), Map (Maybe String) (CmdParser f out (), f ()))
child_fold (c_names, c_map) (ChildGather name child act) =
case name `MapS.lookup` c_map of
Nothing ->
@ -619,14 +627,16 @@ 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 <&> \(name, (child, act)) ->
case input of
InputString str | name == str ->
Just $ (name, child, act, InputString "")
InputString str | (name++" ") `isPrefixOf` str ->
Just $ (name, child, act, InputString $ drop (length name + 1) str)
InputArgs (str:strr) | name == str ->
Just $ (name, child, act, InputArgs strr)
let mRest = asum $ combined_child_list <&> \(mname, (child, act)) ->
case (mname, input) of
(Just name, InputString str) | name == str ->
Just $ (Just name, child, act, InputString "")
(Just name, InputString str) | (name++" ") `isPrefixOf` str ->
Just $ (Just name, child, act, InputString $ drop (length name + 1) str)
(Just name, InputArgs (str:strr)) | name == str ->
Just $ (Just name, child, act, InputArgs strr)
(Nothing, _) ->
Just $ (Nothing, child, act, input)
_ -> Nothing
case mRest of
Nothing -> do -- a child not matching what we have in the input
@ -1051,7 +1061,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
inputToString (InputString s) = s
inputToString (InputArgs ss) = List.unwords ss
dequeLookupRemove :: String -> Deque (String, a) -> (Maybe a, Deque (String, a))
dequeLookupRemove :: Eq k => k -> Deque (k, a) -> (Maybe a, Deque (k, a))
dequeLookupRemove key deque = case Deque.uncons deque of
Nothing -> (Nothing, mempty)
Just ((k, v), rest) -> if k==key
@ -1061,7 +1071,7 @@ dequeLookupRemove key deque = case Deque.uncons deque of
takeCommandChild
:: MonadMultiState (CommandDesc out) m
=> String
=> Maybe String
-> m (Maybe (CommandDesc out))
takeCommandChild key = do
cmd <- mGet
@ -1120,20 +1130,20 @@ descFixParents = descFixParentsWithTopM Nothing
-- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a
-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))
descFixParentsWithTopM :: Maybe (String, CommandDesc a) -> CommandDesc a -> CommandDesc a
descFixParentsWithTopM :: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a
descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc
{ _cmd_mParent = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)
, _cmd_children = _cmd_children topDesc <&> goDown fixed
}
where
goUp :: CommandDesc a -> (String, CommandDesc a) -> (String, CommandDesc a)
goUp :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)
goUp child (childName, parent) = (,) childName $ Data.Function.fix $ \fixed -> parent
{ _cmd_mParent = goUp fixed <$> _cmd_mParent parent
, _cmd_children = _cmd_children parent <&> \(n, c) -> if n==childName
then (n, child)
else (n, c)
}
goDown :: CommandDesc a -> (String, CommandDesc a) -> (String, CommandDesc a)
goDown :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)
goDown parent (childName, child) = (,) childName $ Data.Function.fix $ \fixed -> child
{ _cmd_mParent = Just (childName, parent)
, _cmd_children = _cmd_children child <&> goDown fixed

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

@ -68,7 +68,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 String (CmdParser f out ()) (f ()) a
| CmdParserChild (Maybe String) (CmdParser f out ()) (f ()) a
| CmdParserImpl out a
| CmdParserReorderStart a
| CmdParserReorderStop a
@ -109,14 +109,14 @@ type CmdParser f out = Free (CmdParserF f out)
-- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which
-- might be useful after successful parsing.
data CommandDesc out = CommandDesc
{ _cmd_mParent :: Maybe (String, CommandDesc out)
{ _cmd_mParent :: Maybe (Maybe String, CommandDesc out)
, _cmd_synopsis :: Maybe PP.Doc
, _cmd_help :: Maybe PP.Doc
, _cmd_parts :: [PartDesc]
, _cmd_out :: Maybe out
, _cmd_children :: Deque (String, CommandDesc out) -- we don't use a Map here
-- because we'd like to
-- retain the order.
, _cmd_children :: Deque (Maybe String, CommandDesc out)
-- we don't use a Map here because we'd like to
-- retain the order.
}
-- type PartSeqDesc = [PartDesc]

29
src/UI/Butcher/Monadic/Param.hs
View File

@ -13,6 +13,7 @@ module UI.Butcher.Monadic.Param
, addReadParamOpt
, addStringParam
, addStringParamOpt
, addStringParams
, addRestOfInputStringParam
)
where
@ -108,9 +109,9 @@ addReadParamOpt name par = addCmdPart desc parseF
((x, []):_) -> Just (Just x, [])
_ -> Just (Nothing, s) -- TODO: we could warn about a default..
-- | Add a parameter that matches any string of non-space characters if input
-- String, or one full argument if input is [String]. See the 'Input' doc for
-- this distinction.
-- | Add a parameter that matches any string of non-space characters if
-- input==String, or one full argument if input==[String]. See the 'Input' doc
-- for this distinction.
addStringParam
:: forall f out . (Applicative f)
=> String
@ -153,6 +154,28 @@ addStringParamOpt name par = addCmdPartInp desc parseF
(s1:sR) -> Just (Just s1, InputArgs sR)
[] -> Just (Nothing, InputArgs [])
-- | Add a parameter that matches any string of non-space characters if
-- input==String, or one full argument if input==[String]. See the 'Input' doc
-- for this distinction.
addStringParams
:: forall f out
. (Applicative f)
=> String
-> Param Void
-> CmdParser f out [String]
addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
where
desc :: PartDesc
desc = (maybe id PartWithHelp $ _param_help par) $ PartVariable name
parseF :: Input -> Maybe (String, Input)
parseF (InputString str) =
case break Char.isSpace $ dropWhile Char.isSpace str of
("", _ ) -> Nothing
(x , rest) -> Just (x, InputString rest)
parseF (InputArgs args) = case args of
(s1:sR) -> Just (s1, InputArgs sR)
[] -> Nothing
-- | Add a parameter that consumes _all_ remaining input. Typical usecase is
-- after a "--" as common in certain (unix?) commandline tools.

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

@ -61,9 +61,10 @@ ppUsage :: CommandDesc a -> PP.Doc
ppUsage (CommandDesc mParent _help _syn parts out children) = pparents mParent
<+> PP.sep [PP.fsep partDocs, subsDoc]
where
pparents :: Maybe (String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n
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
subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug
@ -72,10 +73,9 @@ ppUsage (CommandDesc mParent _help _syn parts out children) = pparents mParent
Just{} -> PP.brackets $ subDoc
subDoc =
PP.fcat
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ children
<&> \(n, _) -> PP.text n
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ [ PP.text n | (Just n, _) <- children ]
-- | ppUsageWithHelp exampleDesc yields:
--
@ -87,9 +87,10 @@ ppUsageWithHelp :: CommandDesc a -> PP.Doc
ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) PP.<> helpDoc
where
pparents :: Maybe (String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n
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
subsDoc = case out of
_ | null children -> PP.empty -- TODO: remove debug
@ -98,10 +99,9 @@ ppUsageWithHelp (CommandDesc mParent help _syn parts out children) =
Just{} -> PP.brackets $ subDoc
subDoc =
PP.fcat
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ children
<&> \(n, _) -> PP.text n
$ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList
$ [ PP.text n | (Just n, _) <- children ]
helpDoc = case help of
Nothing -> PP.empty
Just h -> PP.text ":" PP.<+> h
@ -117,7 +117,7 @@ ppUsageAt :: [String] -- (sub)command sequence
ppUsageAt strings desc =
case strings of
[] -> Just $ ppUsage desc
(s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd
(s:sr) -> find ((Just s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd
-- | ppHelpShalloe exampleDesc yields:
--
@ -137,60 +137,56 @@ ppUsageAt strings desc =
-- >
-- > --short make the greeting short
-- > 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) =
nameSection
nameSection
$+$ usageSection
$+$ descriptionSection
$+$ partsSection
$+$ PP.text ""
where
nameSection = case mParent of
Nothing -> PP.empty
Just{} ->
PP.text "NAME"
where
nameSection = case mParent of
Nothing -> PP.empty
Just{} ->
PP.text "NAME"
$+$ PP.text ""
$+$ PP.nest 2 (case syn of
Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s)
$+$ PP.nest
2
( case syn of
Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s
)
$+$ PP.text ""
pparents :: Maybe (String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (n, cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
usageSection =
PP.text "USAGE"
$+$ PP.text ""
$+$ PP.nest 2 (ppUsage desc)
descriptionSection = case help of
Nothing -> PP.empty
Just h ->
PP.text ""
$+$ PP.text "DESCRIPTION"
$+$ PP.text ""
$+$ PP.nest 2 h
partsSection = if null partsTuples then PP.empty else
PP.text ""
$+$ PP.text "ARGUMENTS"
$+$ PP.text ""
$+$ PP.nest 2 (PP.vcat partsTuples)
partsTuples :: [PP.Doc]
partsTuples = parts >>= go
where
go = \case
PartLiteral{} -> []
PartVariable{} -> []
PartOptional p -> go p
PartAlts ps -> ps >>= go
PartSeq ps -> ps >>= go
PartDefault _ p -> go p
PartSuggestion _ p -> go p
PartRedirect s p -> [PP.text s $$ PP.nest 20 (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
pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
pparents Nothing = PP.empty
pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc)
descriptionSection = case help of
Nothing -> PP.empty
Just h ->
PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
partsSection = if null partsTuples
then PP.empty
else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
2
(PP.vcat partsTuples)
partsTuples :: [PP.Doc]
partsTuples = parts >>= go
where
go = \case
PartLiteral{} -> []
PartVariable{} -> []
PartOptional p -> go p
PartAlts ps -> ps >>= go
PartSeq ps -> ps >>= go
PartDefault _ p -> go p
PartSuggestion _ p -> go p
PartRedirect s p ->
[PP.text s $$ PP.nest 20 (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
-- | Internal helper; users probably won't need this.
ppPartDescUsage :: PartDesc -> PP.Doc