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

Allow --flag=value syntax in addition to --flag value

pull/5/head
Lennart Spitzner 2017-05-16 21:02:01 +02:00
parent 6a45f4b3a6
commit 12b886ad31
2 changed files with 221 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src-tests/TestMain.hs
View File

@ -94,6 +94,15 @@ simpleRunTest = do
, "" , ""
, " test a aa | ab" , " test a aa | ab"
] ]
describe "read flags" $ do
it "flag 1" $ testRun testCmd5 "abc" `shouldBe` Right (Just 10)
it "flag 2" $ testRun testCmd5 "abc -f 2" `shouldBe` Right (Just 2)
it "flag 3" $ testRun testCmd5 "abc --flag 3" `shouldBe` Right (Just 3)
it "flag 4" $ testRun testCmd5 "abc -f=4" `shouldBe` Right (Just 4)
it "flag 5" $ testRun testCmd5 "abc --flag=5" `shouldBe` Right (Just 5)
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
@ -152,6 +161,13 @@ testCmd4 = do
addCmd "ba" $ do addCmd "ba" $ do
addCmdImpl $ WriterS.tell 3 addCmdImpl $ WriterS.tell 3
testCmd5 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) ()
testCmd5 = do
addCmd "abc" $ do
x <- addFlagReadParam "f" ["flag"] "flag" (flagDefault (10::Int))
addCmdImpl $ WriterS.tell (Sum x)
testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out) testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out)
testParse cmd s = either (const Nothing) Just testParse cmd s = either (const Nothing) Just
$ snd $ snd

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

@ -1,3 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Flags are arguments to your current command that are prefixed with "-" or -- | Flags are arguments to your current command that are prefixed with "-" or
-- "--", for example "-v" or "--verbose". These flags can have zero or one -- "--", for example "-v" or "--verbose". These flags can have zero or one
@ -43,6 +44,32 @@ import Data.List.Extra ( firstJust )
-- TODO: perhaps move this to Types module and refactor all code to use it
newtype InpParseString a = InpParseString (StateS.StateT String Maybe a)
deriving (Functor, Applicative, Monad, State.Class.MonadState String, Alternative, MonadPlus)
runInpParseString :: String -> InpParseString a -> Maybe (a, String)
runInpParseString s (InpParseString m) = StateS.runStateT m s
pExpect :: String -> InpParseString ()
pExpect s = InpParseString $ do
inp <- StateS.get
case List.stripPrefix s inp of
Nothing -> mzero
Just rest -> StateS.put rest
pExpectEof :: InpParseString ()
pExpectEof =
InpParseString $ StateS.get >>= \inp -> if null inp then pure () else mzero
-- pDropSpace :: InpParseString ()
-- pDropSpace = InpParseString $ StateS.modify (dropWhile (==' '))
pOption :: InpParseString () -> InpParseString ()
pOption m = m <|> return ()
-- | flag-description monoid. You probably won't need to use the constructor; -- | flag-description monoid. You probably won't need to use the constructor;
-- mzero or any (<>) of flag(Help|Default) works well. -- mzero or any (<>) of flag(Help|Default) works well.
data Flag p = Flag data Flag p = Flag
@ -142,30 +169,49 @@ addFlagReadParam
-> String -- ^ param name -> String -- ^ param name
-> Flag p -- ^ properties -> Flag p -- ^ properties
-> CmdParser f out p -> CmdParser f out p
addFlagReadParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ()) addFlagReadParam shorts longs name flag = addCmdPartInpA desc
where parseF
allStrs = fmap (\c -> "-"++[c]) shorts (\_ -> pure ())
++ fmap (\s -> "--"++s) longs where
desc = (maybe id PartWithHelp $ _flag_help flag) allStrs =
$ maybe id (PartDefault . show) (_flag_default flag) [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
$ PartSeq [desc1, desc2] desc =
desc1 :: PartDesc (maybe id PartWithHelp $ _flag_help flag)
desc1 = PartAlts $ PartLiteral <$> allStrs $ maybe id (PartDefault . show) (_flag_default flag)
desc2 = PartVariable name $ PartSeq [desc1, desc2]
parseF :: Input -> Maybe (p, Input) desc1 :: PartDesc
parseF inp = case inp of desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
InputString str -> case flip firstJust allStrs $ \s -> desc2 = PartVariable name
[drop (length s + 1) str | (s ++ " ") `isPrefixOf` str] parseF :: Input -> Maybe (p, Input)
of parseF inp = case inp of
Nothing -> _flag_default flag <&> \x -> (x, InputString str) InputString str ->
Just rest -> case Text.Read.reads rest of maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
((x, ' ':r):_) -> Just (x, InputString $ dropWhile Char.isSpace r) $ parseResult
((x, ""):_) -> Just (x, InputString $ "") where
_ -> Nothing parseResult = runInpParseString str $ do
InputArgs (arg1:argR) | any (==arg1) allStrs -> case argR of Data.Foldable.msum $ allStrs <&> \case
[] -> Nothing Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
case Text.Read.reads i of
((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
((x, "" ):_) -> StateS.put "" $> x
_ -> mzero
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "") -> case argR of
[] -> Nothing
(arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest) (arg2:rest) -> readMaybe arg2 <&> \x -> (x, InputArgs rest)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp) Just ((), remainingStr) ->
readMaybe remainingStr <&> \x -> (x, InputArgs argR)
Nothing -> _flag_default flag <&> \d -> (d, inp)
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag, where the argument is parsed via its Read instance. -- | One-argument flag, where the argument is parsed via its Read instance.
-- This version can accumulate multiple values by using the same flag with -- This version can accumulate multiple values by using the same flag with
@ -199,71 +245,100 @@ addFlagReadParams shorts longs name flag
-- = void $ addFlagReadParamsAll shorts longs name flag act -- = void $ addFlagReadParamsAll shorts longs name flag act
addFlagReadParamsAll addFlagReadParamsAll
:: forall f p out :: forall f p out . (Typeable p, Text.Read.Read p, Show p) => String -- ^ short flag chars, i.e. "v" for -v
. (Typeable p, Text.Read.Read p, Show p) -> [String] -- ^ list of long names, i.e. ["verbose"]
=> String -- ^ short flag chars, i.e. "v" for -v -> String -- ^ param name
-> [String] -- ^ list of long names, i.e. ["verbose"] -> Flag p -- ^ properties
-> String -- ^ param name -> (p -> f ()) -- ^ action to execute when ths param matches
-> Flag p -- ^ properties -> CmdParser f out [p]
-> (p -> f ()) -- ^ action to execute when ths param matches addFlagReadParamsAll shorts longs name flag act = addCmdPartManyInpA
-> CmdParser f out [p] ManyUpperBoundN
addFlagReadParamsAll shorts longs name flag act = desc
addCmdPartManyInpA ManyUpperBoundN desc parseF act parseF
where act
allStrs = fmap (\c -> "-"++[c]) shorts where
++ fmap (\s -> "--"++s) longs allStrs =
desc = (maybe id PartWithHelp $ _flag_help flag) [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
$ PartSeq [desc1, desc2] desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
desc1 :: PartDesc desc1 :: PartDesc
desc1 = PartAlts $ PartLiteral <$> allStrs desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc2 = (maybe id (PartDefault . show) $ _flag_default flag) desc2 =
$ PartVariable name (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
parseF :: Input -> Maybe (p, Input) parseF :: Input -> Maybe (p, Input)
parseF inp = case inp of parseF inp = case inp of
InputString str -> flip firstJust allStrs $ \s -> InputString str -> fmap (second InputString) $ parseResult
[ t where
| (s ++ " ") `isPrefixOf` str parseResult = runInpParseString str $ do
, let rest = drop (length s + 1) str Data.Foldable.msum $ allStrs <&> \case
, t <- case Text.Read.reads rest of Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
((x, ' ':r):_) -> Just (x, InputString $ dropWhile Char.isSpace r) Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
((x, ""):_) -> Just (x, InputString $ "") InpParseString $ do
_ -> _flag_default flag <&> \x -> (x, InputString rest) i <- StateS.get
] case Text.Read.reads i of
InputArgs (arg1:argR) | any (==arg1) allStrs -> case argR of ((x, ' ':r):_) -> StateS.put (dropWhile Char.isSpace r) $> x
[] -> _flag_default flag <&> \d -> (d, InputArgs argR) ((x, "" ):_) -> StateS.put "" $> x
(arg2:rest) -> case readMaybe arg2 of _ -> lift $ _flag_default flag
Just x -> Just (x, InputArgs rest) InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Nothing -> _flag_default flag <&> \d -> (d, InputArgs argR) Just ((), "") -> case argR of
InputArgs _ -> Nothing [] -> mdef
(arg2:rest) -> (readMaybe arg2 <&> \x -> (x, InputArgs rest)) <|> mdef
where mdef = _flag_default flag <&> \p -> (p, InputArgs argR)
Just ((), remainingStr) ->
readMaybe remainingStr <&> \x -> (x, InputArgs argR)
Nothing -> Nothing
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> Nothing
-- | One-argument flag where the argument can be an arbitrary string. -- | One-argument flag where the argument can be an arbitrary string.
addFlagStringParam addFlagStringParam
:: forall f out :: forall f out . (Applicative f) => String -- ^ short flag chars, i.e. "v" for -v
. (Applicative f) -> [String] -- ^ list of long names, i.e. ["verbose"]
=> String -- ^ short flag chars, i.e. "v" for -v -> String -- ^ param name
-> [String] -- ^ list of long names, i.e. ["verbose"] -> Flag String -- ^ properties
-> String -- ^ param name -> CmdParser f out String
-> Flag String -- ^ properties addFlagStringParam shorts longs name flag = addCmdPartInpA desc
-> CmdParser f out String parseF
addFlagStringParam shorts longs name flag = addCmdPartInpA desc parseF (\_ -> pure ()) (\_ -> pure ())
where where
allStrs = fmap (\c -> "-"++[c]) shorts allStrs =
++ fmap (\s -> "--"++s) longs [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc = (maybe id PartWithHelp $ _flag_help flag) desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
$ PartSeq [desc1, desc2] desc1 :: PartDesc
desc1 :: PartDesc desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
desc1 = PartAlts $ PartLiteral <$> allStrs desc2 = PartVariable name
desc2 = PartVariable name parseF :: Input -> Maybe (String, Input)
parseF :: Input -> Maybe (String, Input) parseF inp = case inp of
parseF (InputString str) = case flip firstJust allStrs $ \s -> InputString str ->
[drop (length s + 1) str | (s ++ " ") `isPrefixOf` str] maybe (_flag_default flag <&> \x -> (x, inp)) (Just . second InputString)
of $ parseResult
Nothing -> _flag_default flag <&> \x -> (x, InputString str) where
Just rest1 -> let (x, rest2) = break Char.isSpace $ dropWhile Char.isSpace rest1 parseResult = runInpParseString str $ do
in Just (x, InputString rest2) Data.Foldable.msum $ allStrs <&> \case
parseF (InputArgs (s1:s2:sr)) | any (==s1) allStrs = Just (s2, InputArgs sr) Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
parseF inp@(InputArgs _) = _flag_default flag <&> \x -> (x, inp) Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
InpParseString $ do
i <- StateS.get
let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
StateS.put rest
pure x
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "" ) -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> _flag_default flag <&> \d -> (d, inp)
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> _flag_default flag <&> \d -> (d, inp)
-- | One-argument flag where the argument can be an arbitrary string. -- | One-argument flag where the argument can be an arbitrary string.
-- This version can accumulate multiple values by using the same flag with -- This version can accumulate multiple values by using the same flag with
@ -296,36 +371,49 @@ addFlagStringParams shorts longs name flag
-- = void $ addFlagStringParamsAll shorts longs name flag act -- = void $ addFlagStringParamsAll shorts longs name flag act
addFlagStringParamsAll addFlagStringParamsAll
:: forall f out :: forall f out . String
. String -> [String]
-> [String] -> String
-> String -> Flag Void -- we forbid the default because it has bad interaction
-> Flag Void -- we forbid the default because it has bad interaction
-- with the eat-anything behaviour of the string parser. -- with the eat-anything behaviour of the string parser.
-> (String -> f ()) -> (String -> f ())
-> CmdParser f out [String] -> CmdParser f out [String]
addFlagStringParamsAll shorts longs name flag act = addFlagStringParamsAll shorts longs name flag act = addCmdPartManyInpA
addCmdPartManyInpA ManyUpperBoundN desc parseF act ManyUpperBoundN
where desc
allStrs = fmap (\c -> "-"++[c]) shorts parseF
++ fmap (\s -> "--"++s) longs act
desc = (maybe id PartWithHelp $ _flag_help flag) where
$ PartSeq [desc1, desc2] allStrs =
desc1 :: PartDesc [ Left $ "-" ++ [c] | c <- shorts ] ++ [ Right $ "--" ++ l | l <- longs ]
desc1 = PartAlts $ PartLiteral <$> allStrs desc = (maybe id PartWithHelp $ _flag_help flag) $ PartSeq [desc1, desc2]
desc2 = (maybe id (PartDefault . show) $ _flag_default flag) desc1 :: PartDesc
$ PartVariable name desc1 = PartAlts $ PartLiteral . either id id <$> allStrs
parseF :: Input -> Maybe (String, Input) desc2 =
parseF (InputString str) (maybe id (PartDefault . show) $ _flag_default flag) $ PartVariable name
= flip firstJust allStrs parseF :: Input -> Maybe (String, Input)
$ \s -> [ (x, InputString rest2) parseF inp = case inp of
| (s ++ " ") `isPrefixOf` str InputString str -> fmap (second InputString) $ parseResult
, let rest1 = drop (length s + 1) str where
, let (x, rest2) = break Char.isSpace $ dropWhile Char.isSpace rest1 parseResult = runInpParseString str $ do
] Data.Foldable.msum $ allStrs <&> \case
parseF (InputArgs (s1:s2:sr)) Left s -> pExpect s *> pOption (pExpect " " <|> pExpect "=")
= flip firstJust allStrs Right s -> pExpect s *> (pExpect " " <|> pExpect "=")
$ \s -> [ (s2, InputArgs sr) InpParseString $ do
| s == s1 i <- StateS.get
] let (x, rest) = break Char.isSpace $ dropWhile Char.isSpace i
parseF (InputArgs _) = Nothing StateS.put rest
pure x
InputArgs (arg1:argR) -> case runInpParseString arg1 parser of
Just ((), "" ) -> case argR of
[] -> Nothing
(x:rest) -> Just (x, InputArgs rest)
Just ((), remainingStr) -> Just (remainingStr, InputArgs argR)
Nothing -> Nothing
where
parser :: InpParseString ()
parser = do
Data.Foldable.msum $ allStrs <&> \case
Left s -> pExpect s *> pOption (pExpect "=")
Right s -> pExpect s *> (pExpect "=" <|> pExpectEof)
InputArgs _ -> Nothing