hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Rename param functions, Add `addParamNoFlagString*`, Fix flag behaviour

pull/5/head
Lennart Spitzner 2017-10-03 17:06:15 +02:00
parent bd7f1f3c07
commit b2a25f3a07
5 changed files with 200 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src-tests/TestMain.hs
View File

@ -103,13 +103,20 @@ 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
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 :: CmdParser Identity (WriterS.Writer (Sum Int) [String]) ()
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

4
src/UI/Butcher/Monadic.hs
View File

@ -97,14 +97,14 @@ _cmds :: CmdParser Identity (IO ()) ()
_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

4
src/UI/Butcher/Monadic/BuiltinCommands.hs
View File

@ -31,7 +31,7 @@ import System.IO
-- '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 @@ addHelpCommand desc = addCmd "help" $ do
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

71
src/UI/Butcher/Monadic/Flag.hs
View File

@ -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 @@ addSimpleBoolFlagAll
-> 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
allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
desc :: PartDesc
desc = (maybe id PartWithHelp $ _flag_help flag)
$ PartAlts $ PartLiteral <$> allStrs
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)
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 @@ addSimpleCountFlag :: Applicative f
-> [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
-- 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
allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
desc :: PartDesc
desc = (maybe id PartWithHelp $ _flag_help flag)
$ PartAlts $ PartLiteral <$> allStrs
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)
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 @@ addFlagReadParam
-> 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 @@ addFlagReadParam shorts longs name flag = addCmdPartInpA desc
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 @@ addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
(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 @@ addFlagStringParam shorts longs name flag = addCmdPartInpA desc
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 @@ addFlagStringParam shorts longs name flag = addCmdPartInpA desc
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 @@ addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
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 "=")

131
src/UI/Butcher/Monadic/Param.hs
View File

@ -9,7 +9,17 @@ module UI.Butcher.Monadic.Param
, 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 @@ paramSuggestions ss = mempty { _param_suggestions = Just ss }
-- 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 @@ addReadParam name par = addCmdPart desc parseF
_ -> _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 @@ addReadParamOpt name par = addCmdPart desc parseF
-- | 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 @@ addStringParam name par = addCmdPartInp desc parseF
(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 @@ 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.
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 @@ addStringParams name par = addCmdPartManyInp ManyUpperBoundN desc parseF
[] -> 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