diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/butcher.cabal b/butcher.cabal --- a/butcher.cabal +++ b/butcher.cabal @@ -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 (it is properly formatted on github). license: BSD3 diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs --- a/src-tests/TestMain.hs +++ b/src-tests/TestMain.hs @@ -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 diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs --- a/src/UI/Butcher/Monadic.hs +++ b/src/UI/Butcher/Monadic.hs @@ -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 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 @@ -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 diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs --- a/src/UI/Butcher/Monadic/Flag.hs +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -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 "=") 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 @@ -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