diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,9 @@ -# Revision history for cmdparse-applicative +# Revision history for butcher + +## 1.1.1.0 -- October 2017 + +* Add `addNullCmd` function that descends into childcommand on an epsilon match +* Add `addStringParams` function that reads all remaining words ## 1.1.0.2 -- September 2017 diff --git a/butcher.cabal b/butcher.cabal --- a/butcher.cabal +++ b/butcher.cabal @@ -1,5 +1,5 @@ name: butcher -version: 1.1.0.2 +version: 1.1.1.0 synopsis: Chops a command or program invocation into digestable pieces. description: See the (it is properly formatted on github). license: BSD3 @@ -90,7 +90,6 @@ ghc-options: { -Wall -fno-spec-constr - -j -fno-warn-unused-imports -fno-warn-orphans } @@ -148,7 +147,6 @@ ghc-options: { -Wall -fno-spec-constr - -j -fno-warn-unused-imports -fno-warn-orphans } diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs --- a/src-tests/TestMain.hs +++ b/src-tests/TestMain.hs @@ -103,7 +103,13 @@ 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,7 +173,17 @@ 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 $ snd @@ -177,6 +193,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) diff --git a/src/UI/Butcher/Monadic/BuiltinCommands.hs b/src/UI/Butcher/Monadic/BuiltinCommands.hs --- a/src/UI/Butcher/Monadic/BuiltinCommands.hs +++ b/src/UI/Butcher/Monadic/BuiltinCommands.hs @@ -38,7 +38,7 @@ 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 diff --git a/src/UI/Butcher/Monadic/Command.hs b/src/UI/Butcher/Monadic/Command.hs --- a/src/UI/Butcher/Monadic/Command.hs +++ b/src/UI/Butcher/Monadic/Command.hs @@ -53,6 +53,7 @@ module UI.Butcher.Monadic.Command ( addCmd + , addNullCmd , addCmdImpl , addCmdSynopsis , addCmdHelp diff --git a/src/UI/Butcher/Monadic/Internal/Core.hs b/src/UI/Butcher/Monadic/Internal/Core.hs --- a/src/UI/Butcher/Monadic/Internal/Core.hs +++ b/src/UI/Butcher/Monadic/Internal/Core.hs @@ -21,6 +21,7 @@ , addCmdPartManyInp , addCmdPartManyInpA , addCmd + , addNullCmd , addCmdImpl , reorderStart , reorderStop @@ -215,8 +216,15 @@ => 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 () addCmdImpl o = liftF $ CmdParserImpl o () @@ -264,7 +272,7 @@ , _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 @@ 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 @@ $ 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 @@ 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 @@ 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 @@ 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 @@ takeCommandChild :: MonadMultiState (CommandDesc out) m - => String + => Maybe String -> m (Maybe (CommandDesc out)) takeCommandChild key = do cmd <- mGet @@ -1120,20 +1130,20 @@ -- 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 diff --git a/src/UI/Butcher/Monadic/Internal/Types.hs b/src/UI/Butcher/Monadic/Internal/Types.hs --- a/src/UI/Butcher/Monadic/Internal/Types.hs +++ b/src/UI/Butcher/Monadic/Internal/Types.hs @@ -68,7 +68,7 @@ | 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 @@ -- 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] diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs --- a/src/UI/Butcher/Monadic/Param.hs +++ b/src/UI/Butcher/Monadic/Param.hs @@ -13,6 +13,7 @@ , addReadParamOpt , addStringParam , addStringParamOpt + , addStringParams , addRestOfInputStringParam ) where @@ -108,9 +109,9 @@ ((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 @@ -152,6 +153,28 @@ parseF (InputArgs args) = case args of (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 diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs --- a/src/UI/Butcher/Monadic/Pretty.hs +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -61,9 +61,10 @@ 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 @@ 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 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 @@ 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 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 @@ -- > -- > --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" - $+$ PP.text "" - $+$ 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" + where + nameSection = case mParent of + Nothing -> PP.empty + Just{} -> + PP.text "NAME" $+$ PP.text "" - $+$ PP.nest 2 h - partsSection = if null partsTuples then PP.empty else - PP.text "" - $+$ PP.text "ARGUMENTS" + $+$ PP.nest + 2 + ( case syn of + Nothing -> pparents mParent + Just s -> pparents mParent <+> PP.text "-" <+> s + ) $+$ 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