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

src-tests/TestMain.hs

@@ -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

src/UI/Butcher/Monadic.hs

@@ -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

src/UI/Butcher/Monadic/BuiltinCommands.hs

@@ -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

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 @@ addSimpleBoolFlagAll
   -> Flag Void
   -> f ()
   -> CmdParser f out Bool
-addSimpleBoolFlagAll shorts longs flag a
+addSimpleBoolFlagAll shorts longs flag a = fmap (not . null)
-  = fmap (not . null)
   $ addCmdPartManyA ManyUpperBound1 desc parseF (\() -> a)
-  where
+ where
-    allStrs = fmap (\c -> "-"++[c]) shorts
+  allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
-           ++ fmap (\s -> "--"++s)  longs
+  desc :: PartDesc
-    desc :: PartDesc
+  desc =
-    desc = (maybe id PartWithHelp $ _flag_help flag)
+    (maybe id PartWithHelp $ _flag_help flag)
-         $ PartAlts $ PartLiteral <$> allStrs
+      $   PartAlts
-    parseF :: String -> Maybe ((), String)
+      $   PartLiteral
-    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])
+      <$> allStrs
-                             allStrs)
+  parseF :: String -> Maybe ((), String)
-             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)
+  parseF (dropWhile Char.isSpace -> str) =
-                                    | (s ++ " ") `isPrefixOf` str ])
+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-                             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
+addSimpleCountFlag shorts longs flag = fmap length
-  = 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
+  allStrs = fmap (\c -> "-" ++ [c]) shorts ++ fmap (\s -> "--" ++ s) longs
-           ++ fmap (\s -> "--"++s)  longs
+  desc :: PartDesc
-    desc :: PartDesc
+  desc =
-    desc = (maybe id PartWithHelp $ _flag_help flag)
+    (maybe id PartWithHelp $ _flag_help flag)
-         $ PartAlts $ PartLiteral <$> allStrs
+      $   PartAlts
-    parseF :: String -> Maybe ((), String)
+      $   PartLiteral
-    parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ])
+      <$> allStrs
-                             allStrs)
+  parseF :: String -> Maybe ((), String)
-             <|> ( firstJust (\s -> [ ((), drop (length s + 1) str)
+  parseF (dropWhile Char.isSpace -> str) =
-                                    | (s ++ " ") `isPrefixOf` str ])
+    (firstJust (\s -> [ ((), drop (length s) str) | s == str ]) allStrs)
-                             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
+addFlagReadParam shorts longs name flag =
-                                                         parseF
+  addCmdPartInpA desc parseF (\_ -> pure ())
-                                                         (\_ -> 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 "=")

src/UI/Butcher/Monadic/Param.hs

@@ -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