butcher 1.1.0.2 → 1.1.1.0

raw patch · 9 files changed

+151/−95 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• butcher.cabal +1/−3
• src-tests/TestMain.hs +24/−1
• src/UI/Butcher/Monadic/BuiltinCommands.hs +1/−1
• src/UI/Butcher/Monadic/Command.hs +1/−0
• src/UI/Butcher/Monadic/Internal/Core.hs +29/−19
• src/UI/Butcher/Monadic/Internal/Types.hs +5/−5
• src/UI/Butcher/Monadic/Param.hs +26/−3
• src/UI/Butcher/Monadic/Pretty.hs +58/−62

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

@@ -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 <https://github.com/lspitzner/butcher/blob/master/README.md README> (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   }

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

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

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

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

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

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

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