Add `addNullCmd` and `addStringParams`

src-tests/TestMain.hs

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

src/UI/Butcher/Monadic/BuiltinCommands.hs

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

src/UI/Butcher/Monadic/Command.hs

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

src/UI/Butcher/Monadic/Internal/Core.hs

@@ -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)) ->
+        let mRest = asum $ combined_child_list <&> \(mname, (child, act)) ->
-              case input of
+              case (mname, input) of
-                InputString str | name == str ->
+                (Just name, InputString str) | name == str ->
-                  Just $ (name, child, act, InputString "")
+                  Just $ (Just name, child, act, InputString "")
-                InputString str | (name++" ") `isPrefixOf` str ->
+                (Just name, InputString str) | (name++" ") `isPrefixOf` str ->
-                  Just $ (name, child, act, InputString $ drop (length name + 1) str)
+                  Just $ (Just name, child, act, InputString $ drop (length name + 1) str)
-                InputArgs (str:strr) | name == str ->
+                (Just name, InputArgs (str:strr)) | name == str ->
-                  Just $ (name, child, act, InputArgs strr)
+                  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

src/UI/Butcher/Monadic/Internal/Types.hs

@@ -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
+  , _cmd_children :: Deque (Maybe String, CommandDesc out)
-                                                     -- because we'd like to
+                     -- we don't use a Map here because we'd like to
-                                                     -- retain the order.
+                     -- retain the order.
   }
 
 -- type PartSeqDesc = [PartDesc]

src/UI/Butcher/Monadic/Param.hs

@@ -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
+-- | Add a parameter that matches any string of non-space characters if
--- String, or one full argument if input is [String]. See the 'Input' doc for
+-- input==String, or one full argument if input==[String]. See the 'Input' doc
--- this distinction.
+-- 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.

src/UI/Butcher/Monadic/Pretty.hs

@@ -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 :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing        = PP.empty
+  pparents Nothing              = PP.empty
-  pparents (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)
   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 " | ")
+      $ PP.punctuate (PP.text " | ")
-      $   Data.Foldable.toList
+      $ Data.Foldable.toList
-      $   children
+      $ [ PP.text n | (Just n, _) <- children ]
-      <&> \(n, _) -> PP.text n
 
 -- | 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 :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-  pparents Nothing        = PP.empty
+  pparents Nothing              = PP.empty
-  pparents (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)
   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 " | ")
+      $ PP.punctuate (PP.text " | ")
-      $   Data.Foldable.toList
+      $ Data.Foldable.toList
-      $   children
+      $ [ PP.text n | (Just n, _) <- children ]
-      <&> \(n, _) -> PP.text n
   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
+ppHelpShallow :: CommandDesc a -> PP.Doc
-              -> PP.Doc
 ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) =
-        nameSection
+  nameSection
     $+$ usageSection
     $+$ descriptionSection
     $+$ partsSection
     $+$ PP.text ""
-  where
+ where
-    nameSection = case mParent of
+  nameSection = case mParent of
-      Nothing -> PP.empty
+    Nothing -> PP.empty
-      Just{} ->
+    Just{} ->
-            PP.text "NAME"
+      PP.text "NAME"
         $+$ PP.text ""
-        $+$ PP.nest 2 (case syn of
+        $+$ PP.nest
-                        Nothing -> pparents mParent
+              2
-                        Just s ->  pparents mParent <+> PP.text "-" <+> s)
+              ( case syn of
+                Nothing -> pparents mParent
+                Just s  -> pparents mParent <+> PP.text "-" <+> s
+              )
         $+$ PP.text ""
-    pparents :: Maybe (String, CommandDesc out) -> PP.Doc
+  pparents :: Maybe (Maybe String, CommandDesc out) -> PP.Doc
-    pparents Nothing = PP.empty
+  pparents Nothing              = PP.empty
-    pparents (Just (n, cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
+  pparents (Just (Just n , cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n
-    usageSection =
+  pparents (Just (Nothing, cd)) = pparents (_cmd_mParent cd)
-            PP.text "USAGE"
+  usageSection = PP.text "USAGE" $+$ PP.text "" $+$ PP.nest 2 (ppUsage desc)
-        $+$ PP.text ""
+  descriptionSection = case help of
-        $+$ PP.nest 2 (ppUsage desc)
+    Nothing -> PP.empty
-    descriptionSection = case help of
+    Just h ->
-      Nothing -> PP.empty
+      PP.text "" $+$ PP.text "DESCRIPTION" $+$ PP.text "" $+$ PP.nest 2 h
-      Just h ->
+  partsSection = if null partsTuples
-            PP.text ""
+    then PP.empty
-        $+$ PP.text "DESCRIPTION"
+    else PP.text "" $+$ PP.text "ARGUMENTS" $+$ PP.text "" $+$ PP.nest
-        $+$ PP.text ""
+      2
-        $+$ PP.nest 2 h
+      (PP.vcat partsTuples)
-    partsSection = if null partsTuples then PP.empty else
+  partsTuples :: [PP.Doc]
-            PP.text ""
+  partsTuples = parts >>= go
-        $+$ PP.text "ARGUMENTS"
+   where
-        $+$ PP.text ""
+    go = \case
-        $+$ PP.nest 2 (PP.vcat partsTuples)
+      PartLiteral{}      -> []
-    partsTuples :: [PP.Doc]
+      PartVariable{}     -> []
-    partsTuples = parts >>= go
+      PartOptional p     -> go p
-      where
+      PartAlts     ps    -> ps >>= go
-        go = \case
+      PartSeq      ps    -> ps >>= go
-          PartLiteral{} -> []
+      PartDefault    _ p -> go p
-          PartVariable{} -> []
+      PartSuggestion _ p -> go p
-          PartOptional p -> go p
+      PartRedirect s p ->
-          PartAlts ps -> ps >>= go
+        [PP.text s $$ PP.nest 20 (ppPartDescUsage p)] ++ (PP.nest 2 <$> go p)
-          PartSeq  ps -> ps >>= go
+      PartReorder ps     -> ps >>= go
-          PartDefault _ p -> go p
+      PartMany    p      -> go p
-          PartSuggestion _ p -> go p
+      PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] ++ 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