From 4b7f8681e75b6a8c10bd5fed9ad33439ade9035e Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <lsp@informatik.uni-kiel.de>
Date: Wed, 3 Aug 2016 22:57:08 +0200
Subject: [PATCH] Fix addFlagReadParamAll for InputArgs case

---
 src/UI/Butcher/Monadic/Flag.hs | 28 ++++++++++++++++++----------
 1 file changed, 18 insertions(+), 10 deletions(-)

diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs
index 21ca726..11fe35f 100644
--- a/src/UI/Butcher/Monadic/Flag.hs
+++ b/src/UI/Butcher/Monadic/Flag.hs
@@ -143,7 +143,7 @@ addFlagReadParamAll
   -> Flag p
   -> (p -> f ())
   -> CmdParser f out [p]
-addFlagReadParamAll shorts longs name flag act = addCmdPartManyA desc parseF act
+addFlagReadParamAll shorts longs name flag act = addCmdPartManyInpA desc parseF act
   where
     allStrs = fmap (\c -> "-"++[c]) shorts
            ++ fmap (\s -> "--"++s)  longs
@@ -153,15 +153,23 @@ addFlagReadParamAll shorts longs name flag act = addCmdPartManyA desc parseF act
     desc1 = PartAlts $ PartLiteral <$> allStrs
     desc2 = (maybe id (PartDefault . show) $ _flag_default flag)
           $ PartVariable name
-    parseF :: String -> Maybe (p, String)
-    parseF str = flip firstJust allStrs
-               $ \s -> [ t
-                       | (s ++ " ") `isPrefixOf` str
-                       , t <- case Text.Read.reads $ drop (length s + 1) str of
-                          ((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r)
-                          ((x, []):_)    -> Just (x, [])
-                          _ -> _flag_default flag <&> \x -> (x, s)
-                       ]
+    parseF :: Input -> Maybe (p, Input)
+    parseF inp = case inp of
+      InputString str -> flip firstJust allStrs $ \s ->
+        [ t
+        | (s ++ " ") `isPrefixOf` str
+        , let rest = drop (length s + 1) str
+        , t <- case Text.Read.reads rest of
+           ((x, ' ':r):_) -> Just (x, InputString $ dropWhile Char.isSpace r)
+           ((x, ""):_)    -> Just (x, InputString $ "")
+           _ -> _flag_default flag <&> \x -> (x, InputString rest)
+        ]
+      InputArgs (arg1:argR) | any (==arg1) allStrs -> case argR of
+        [] -> _flag_default flag <&> \d -> (d, InputArgs argR)
+        (arg2:rest) -> case readMaybe arg2 of
+          Just x -> Just (x, InputArgs rest)
+          Nothing -> _flag_default flag <&> \d -> (d, InputArgs argR)
+      InputArgs _ -> Nothing
 
 addFlagStringParam
   :: forall f out