butcher 1.1.1.0 → 1.2.0.0

raw patch · 7 files changed

+214/−46 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• butcher.cabal +1/−1
• src-tests/TestMain.hs +21/−2
• src/UI/Butcher/Monadic.hs +2/−2
• src/UI/Butcher/Monadic/BuiltinCommands.hs +2/−2
• src/UI/Butcher/Monadic/Flag.hs +46/−37
• src/UI/Butcher/Monadic/Param.hs +129/−2

@@ -1,5 +1,18 @@ # Revision history for butcher +## 1.2.0.0  -- October 2017++* Rename some `Monadic.Param.*`, deprecate old versions.+    - `addReadParam` -> `addParamRead`+    - `addReadParamOpt` -> `addParamReadOpt`+    - `addStringParam` -> `addParamString`+    - `addStringParamOpt` -> `addParamStringOpt`+    - `addStringParams` -> `addParamStrings`+    - `addRestOfInputStringParam` -> `addParamRestOfInput`+* Add functions `addParamNoFlagString`, `addParamNoFlagStringOpt`,+  `addParamNoFlagStrings`+* Fix flag parsing behaviour (ignore initial spaces)+ ## 1.1.1.0  -- October 2017  * Add `addNullCmd` function that descends into childcommand on an epsilon match

@@ -1,5 +1,5 @@ name:                butcher-version:             1.1.1.0+version:             1.2.0.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

@@ -103,13 +103,20 @@     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+  describe "addParamStrings" $ 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))+  describe "addParamNoFlagStrings" $ do+    it "case 1" $ testRun' testCmd7 "" `shouldBe` Right (Just ([], 0))+    it "case 2" $ testRun' testCmd7 "-f" `shouldBe` Right (Just ([], 1))+    it "case 3" $ testRun' testCmd7 "abc" `shouldBe` Right (Just (["abc"], 0))+    it "case 4" $ testRun' testCmd7 "abc -f" `shouldBe` Right (Just (["abc"], 1))+    it "case 5" $ testRun' testCmd7 "-g abc -f" `shouldBe` Right (Just (["abc"], 3))+    it "case 6" $ testRun' testCmd7 "abc -g def" `shouldBe` Right (Just (["abc", "def"], 2))   @@ -177,7 +184,19 @@ testCmd6 = do   f <- addSimpleBoolFlag "f" ["flong"] mempty   g <- addSimpleBoolFlag "g" ["glong"] mempty-  args <- addStringParams "ARGS" mempty+  args <- addParamStrings "ARGS" mempty+  addCmdImpl $ do+    when f $ WriterS.tell 1+    when g $ WriterS.tell 2+    pure args++testCmd7 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()+testCmd7 = do+  reorderStart+  f <- addSimpleBoolFlag "f" ["flong"] mempty+  g <- addSimpleBoolFlag "g" ["glong"] mempty+  args <- addParamNoFlagStrings "ARGS" mempty+  reorderStop   addCmdImpl $ do     when f $ WriterS.tell 1     when g $ WriterS.tell 2

@@ -97,14 +97,14 @@ _cmds = do   addCmd "echo" $ do     addCmdHelpStr "print its parameter to output"-    str <- addReadParam "STRING" (paramHelpStr "the string to print")+    str <- addParamRead "STRING" (paramHelpStr "the string to print")     addCmdImpl $ do       putStrLn str   addCmd "hello" $ do     addCmdHelpStr "greet the user"     reorderStart     short <- addSimpleBoolFlag "" ["short"] mempty-    name <- addReadParam "NAME" (paramHelpStr "your name, so you can be greeted properly"+    name <- addParamRead "NAME" (paramHelpStr "your name, so you can be greeted properly"                               <> paramDefault "user")     reorderStop     addCmdImpl $ do

@@ -31,7 +31,7 @@ -- 'UI.Butcher.Monadic.IO.mainFromCmdParserWithHelpDesc'. addHelpCommand :: Applicative f => CommandDesc () -> CmdParser f (IO ()) () addHelpCommand desc = addCmd "help" $ do-  rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty+  rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty   addCmdImpl $ do     let parentDesc = maybe undefined snd (_cmd_mParent desc)     let restWords  = List.words rest@@ -54,7 +54,7 @@ addHelpCommandShallow :: Applicative f => CmdParser f (IO ()) () addHelpCommandShallow = addCmd "help" $ do   desc <- peekCmdDesc-  _rest <- addRestOfInputStringParam "SUBCOMMAND(s)" mempty+  _rest <- addParamRestOfInput "SUBCOMMAND(s)" mempty   addCmdImpl $ do     let parentDesc = maybe undefined snd (_cmd_mParent desc)     print $ ppHelpShallow $ parentDesc

@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns #-}  -- | Flags are arguments to your current command that are prefixed with "-" or -- "--", for example "-v" or "--verbose". These flags can have zero or one@@ -119,21 +120,25 @@   -> Flag Void   -> f ()   -> CmdParser f out Bool-addSimpleBoolFlagAll shorts longs flag a-  = fmap (not . null)+addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)   $ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)-  where-    allStrs = fmap (\c -> "-"++[c]) shorts-           ++ fmap (\s -> "--"++s)  longs-    desc :: PartDesc-    desc = (maybe id PartWithHelp $ _flag_help flag)-         $ PartAlts $ PartLiteral <$> allStrs-    parseF :: String -> Maybe ((), String)-    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])-                             allStrs)-             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)-                                    | (s ++ " ") `isPrefixOf` str ])-                             allStrs)+ where+  allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs+  desc :: PartDesc+  desc =+    (maybe id PartWithHelp $ _flag_help flag)+      $   PartAlts+      $   PartLiteral+      <$> allStrs+  parseF :: String -> Maybe ((), String)+  parseF (dropWhile Char.isSpace -> str) =+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)+      <|> ( firstJust+            ( \s ->+              [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]+            )+            allStrs+          )  -- | A no-parameter flag that can occur multiple times. Returns the number of -- occurences (0 or more).@@ -142,23 +147,27 @@                    -> [String] -- ^ list of long names, i.e. ["verbose"]                    -> Flag Void -- ^ properties                    -> CmdParser f out Int-addSimpleCountFlag shorts longs flag-  = fmap length+addSimpleCountFlag shorts longs flag = fmap length   $ addCmdPartMany ManyUpperBoundN desc parseF-  where+ where     -- we _could_ allow this to parse repeated short flags, like "-vvv"     -- (meaning "-v -v -v") correctly.-    allStrs = fmap (\c -> "-"++[c]) shorts-           ++ fmap (\s -> "--"++s)  longs-    desc :: PartDesc-    desc = (maybe id PartWithHelp $ _flag_help flag)-         $ PartAlts $ PartLiteral <$> allStrs-    parseF :: String -> Maybe ((), String)-    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])-                             allStrs)-             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)-                                    | (s ++ " ") `isPrefixOf` str ])-                             allStrs)+  allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs+  desc :: PartDesc+  desc =+    (maybe id PartWithHelp $ _flag_help flag)+      $   PartAlts+      $   PartLiteral+      <$> allStrs+  parseF :: String -> Maybe ((), String)+  parseF (dropWhile Char.isSpace -> str) =+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)+      <|> ( firstJust+            ( \s ->+              [ ((), drop (length s + 1) str) | (s ++ " ") `isPrefixOf` str ]+            )+            allStrs+          )  -- | One-argument flag, where the argument is parsed via its Read instance. addFlagReadParam@@ -169,9 +178,8 @@   -> String -- ^ param name   -> Flag p -- ^ properties   -> CmdParser f out p-addFlagReadParam shorts longs name flag = addCmdPartInpA desc-                                                         parseF-                                                         (\_ -> pure ())+addFlagReadParam shorts longs name flag =+  addCmdPartInpA desc parseF (\_ -> pure ())  where   allStrs =     [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]@@ -188,7 +196,7 @@       maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)         $ parseResult      where-      parseResult = runInpParseString str $ do+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do         Data.Foldable.msum $ allStrs <&> \case           Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")           Right s -> pExpect s *> (pExpect " " <|> pExpect "=")@@ -266,9 +274,10 @@     (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name   parseF :: Input -> Maybe (p, Input)   parseF inp = case inp of-    InputString str -> fmap (second InputString) $ parseResult+    InputString str ->+      fmap (second InputString) $ parseResult      where-      parseResult = runInpParseString str $ do+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do         Data.Foldable.msum $ allStrs <&> \case           Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")           Right s -> pExpect s *> (pExpect " " <|> pExpect "=")@@ -317,7 +326,7 @@       maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)         $ parseResult      where-      parseResult = runInpParseString str $ do+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do         Data.Foldable.msum $ allStrs <&> \case           Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")           Right s -> pExpect s *> (pExpect " " <|> pExpect "=")@@ -327,7 +336,7 @@           StateS.put rest           pure x     InputArgs (arg1:argR) -> case runInpParseString arg1 parser of-      Just ((), ""          ) -> case argR of+      Just ((), "") -> case argR of         []       -> Nothing         (x:rest) -> Just (x, InputArgs rest)       Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)@@ -395,7 +404,7 @@   parseF inp = case inp of     InputString str -> fmap (second InputString) $ parseResult      where-      parseResult = runInpParseString str $ do+      parseResult = runInpParseString (dropWhile Char.isSpace str) $ do         Data.Foldable.msum $ allStrs <&> \case           Left  s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")           Right s -> pExpect s *> (pExpect " " <|> pExpect "=")

@@ -9,7 +9,17 @@   , paramHelpStr   , paramDefault   , paramSuggestions-  , addReadParam+  , addParamRead+  , addParamReadOpt+  , addParamString+  , addParamStringOpt+  , addParamStrings+  , addParamNoFlagString+  , addParamNoFlagStringOpt+  , addParamNoFlagStrings+  , addParamRestOfInput+  , -- * Deprecated for more consistent naming+    addReadParam   , addReadParamOpt   , addStringParam   , addStringParamOpt@@ -74,6 +84,13 @@ -- instance. Take care not to use this to return Strings unless you really -- want that, because it will require the quotation marks and escaping as -- is normal for the Show/Read instances for String.+addParamRead :: forall f out a+              . (Applicative f, Typeable a, Show a, Text.Read.Read a)+             => String -- ^ paramater name, for use in usage/help texts+             -> Param a -- ^ properties+             -> CmdParser f out a+addParamRead = addReadParam+{-# DEPRECATED addReadParam "use 'addParamRead'" #-} addReadParam :: forall f out a               . (Applicative f, Typeable a, Show a, Text.Read.Read a)              => String -- ^ paramater name, for use in usage/help texts@@ -92,6 +109,13 @@       _ -> _param_default par <&> \x -> (x, s)  -- | Like addReadParam, but optional. I.e. if reading fails, returns Nothing.+addParamReadOpt :: forall f out a+                 . (Applicative f, Typeable a, Text.Read.Read a)+                => String -- ^ paramater name, for use in usage/help texts+                -> Param a -- ^ properties+                -> CmdParser f out (Maybe a)+addParamReadOpt = addReadParamOpt+{-# DEPRECATED addReadParamOpt "use 'addParamReadOpt'" #-} addReadParamOpt :: forall f out a                  . (Applicative f, Typeable a, Text.Read.Read a)                 => String -- ^ paramater name, for use in usage/help texts@@ -112,6 +136,13 @@ -- | 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.+addParamString+  :: forall f out . (Applicative f)+  => String+  -> Param String+  -> CmdParser f out String+addParamString = addStringParam+{-# DEPRECATED addStringParam "use 'addParamString'" #-} addStringParam   :: forall f out . (Applicative f)   => String@@ -132,8 +163,15 @@       (s1:sR) -> Just (s1, InputArgs sR)       []      -> _param_default par <&> \x -> (x, InputArgs args) --- | Like 'addStringParam', but optional, I.e. succeeding with Nothing if+-- | Like 'addParamString', but optional, I.e. succeeding with Nothing if -- there is no remaining input.+addParamStringOpt+  :: forall f out . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out (Maybe String)+addParamStringOpt = addStringParamOpt+{-# DEPRECATED addStringParamOpt "use 'addParamStringOpt'" #-} addStringParamOpt   :: forall f out . (Applicative f)   => String@@ -154,9 +192,18 @@       (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.+addParamStrings+  :: forall f out+   . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out [String]+addParamStrings = addStringParams+{-# DEPRECATED addStringParams "use 'addParamStrings'" #-} addStringParams   :: forall f out    . (Applicative f)@@ -177,8 +224,88 @@     []      -> Nothing  +-- | Like 'addParamString' but does not match strings starting with a dash.+-- This prevents misinterpretation of flags as params.+addParamNoFlagString+  :: forall f out . (Applicative f)+  => String+  -> Param String+  -> CmdParser f out String+addParamNoFlagString name par = addCmdPartInp desc parseF+ where+  desc :: PartDesc+  desc =+    addSuggestion (_param_suggestions par)+      $ (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+      (""   , rest) -> _param_default par <&> \x -> (x, InputString rest)+      ('-':_, _   ) -> _param_default par <&> \x -> (x, InputString str)+      (x    , rest) -> Just (x, InputString rest)+  parseF (InputArgs args) = case args of+    []           -> _param_default par <&> \x -> (x, InputArgs args)+    (('-':_):_ ) -> _param_default par <&> \x -> (x, InputArgs args)+    (s1     :sR) -> Just (s1, InputArgs sR)++-- | Like 'addParamStringOpt' but does not match strings starting with a dash.+-- This prevents misinterpretation of flags as params.+addParamNoFlagStringOpt+  :: forall f out+   . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out (Maybe String)+addParamNoFlagStringOpt name par = addCmdPartInp desc parseF+ where+  desc :: PartDesc+  desc =+    PartOptional $ (maybe id PartWithHelp $ _param_help par) $ PartVariable name+  parseF :: Input -> Maybe (Maybe String, Input)+  parseF (InputString str) =+    case break Char.isSpace $ dropWhile Char.isSpace str of+      (""   , rest) -> Just (Nothing, InputString rest)+      ('-':_, _   ) -> Just (Nothing, InputString str)+      (x    , rest) -> Just (Just x, InputString rest)+  parseF (InputArgs args) = case args of+    []           -> Just (Nothing, InputArgs [])+    (('-':_):_ ) -> Just (Nothing, InputArgs args)+    (s1     :sR) -> Just (Just s1, InputArgs sR)++-- | Like 'addParamStrings' but does not match strings starting with a dash.+-- This prevents misinterpretation of flags as params.+addParamNoFlagStrings+  :: forall f out+   . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out [String]+addParamNoFlagStrings 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+      ('-':_, _   ) -> Nothing+      (x    , rest) -> Just (x, InputString rest)+  parseF (InputArgs args) = case args of+    []           -> Nothing+    (('-':_):_ ) -> Nothing+    (s1     :sR) -> Just (s1, InputArgs sR)++ -- | Add a parameter that consumes _all_ remaining input. Typical usecase is -- after a "--" as common in certain (unix?) commandline tools.+addParamRestOfInput+  :: forall f out . (Applicative f)+  => String+  -> Param Void+  -> CmdParser f out String+addParamRestOfInput = addRestOfInputStringParam+{-# DEPRECATED addRestOfInputStringParam "use 'addParamRestOfInput'" #-} addRestOfInputStringParam   :: forall f out . (Applicative f)   => String