flags-applicative 0.0.2.0 → 0.0.3.0

raw patch · 4 files changed

+107/−66 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• app/SimpleExample.hs +2/−2
• flags-applicative.cabal +1/−1
• src/Flags/Applicative.hs +97/−61
• test/Spec.hs +7/−2

@@ -17,9 +17,9 @@  optionsParser :: FlagParser Options optionsParser = Options <$> (textFlag "root" "path to the root" <|> textFlag "url" "")-                        <*> (flag "log_level" "" <|> pure 0)+                        <*> (autoFlag "log_level" "" <|> pure 0)                         <*> (optional $ textFlag "context" "")-                        <*> (repeatedFlag "," "values" "" <|> pure [])+                        <*> (autoListFlag "," "values" "" <|> pure [])  main :: IO () main = parseSystemFlagsOrDie optionsParser >>= print

@@ -1,5 +1,5 @@ name:                flags-applicative-version:             0.0.2.0+version:             0.0.3.0 synopsis:            Applicative flag parsing description:         https://github.com/mtth/flags-applicative homepage:            https://github.com/mtth/flags-applicative

@@ -22,7 +22,7 @@ -- -- optionsParser :: FlagParser Options -- optionsParser = Options \<$\> textFlag "root" "path to the root"---                         \<*\> (flag "log_level" "" \<|\> pure 0)+--                         \<*\> (autoFlag "log_level" "" \<|\> pure 0) --                         \<*\> (optional $ textFlag "context" "") -- -- main :: IO ()@@ -31,13 +31,11 @@ --   print opts -- @ --- TODO: Add @--help@ support.- module Flags.Applicative   ( Name, Description, FlagParser, FlagError(..)   , parseFlags, parseSystemFlagsOrDie   -- * Defining flags-  , switch, unaryFlag, textFlag, flag, repeatedTextFlag, repeatedFlag+  , switch, flag, textFlag, autoFlag, textListFlag, autoListFlag   ) where  import Control.Applicative ((<|>), Alternative, empty, optional)@@ -48,7 +46,7 @@ import Control.Monad.State.Strict (get, modify, put) import Control.Monad.Writer.Strict (tell) import Data.Bifunctor (first, second)-import Data.Foldable (toList)+import Data.Foldable (foldl', toList) import Data.List (isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map)@@ -63,23 +61,32 @@ import qualified Data.Text as T import Text.Read (readEither) --- | The name of a flag, can use all valid utf-8 characters but @=@ (the value delimiter). In--- general, it's good practice for flag names to be lowercase ASCII with underscores.+-- The prefix used to identify all flags.+prefix :: String+prefix = "--"++-- | The name of a flag (without the @--@ prefix). Names can use all valid utf-8 characters except+-- @=@ (the value delimiter). In general, it's good practice for flag names to be lowercase ASCII+-- with underscores. -- -- The following names are reserved and attempting to define a flag with the same name will cause an -- error: ----- * @help@, used to display usage when set.+-- * @help@, displays usage when set.+-- * @swallowed_flags@, flags in this list which are set but undeclared will be ignored rather than+-- cause an error during parsing.+-- * @swallowed_switches@, similar to @swallowed_flags@ but for switches (nullary flags). type Name = Text --- The name of the help switch.-helpName :: Name-helpName = "help"+-- Add the flag prefix to a name.+qualify :: Name -> Text+qualify name = T.pack prefix <> name  -- | An human-readable explanation of what the flag does. type Description = Text  data Arity = Nullary | Unary deriving Eq+ data Flag = Flag Arity Description  -- The errors which can happen during flag parsing.@@ -117,11 +124,9 @@  displayUsage :: Map Name Flag -> Usage -> Text displayUsage flags usage = "usage: " <> go usage <> "\n" <> details where-  go (Exactly name) =-    let prefix = "--" <> name-    in case Map.lookup name flags of-      Just (Flag Unary _) -> prefix <> "=*"-      _ -> prefix+  go (Exactly name) = case Map.lookup name flags of+    Just (Flag Unary _) -> qualify name <> "=*"+    _ -> qualify name   go (AllOf s) =     T.intercalate " " $ fmap go $ filter (/= emptyUsage) $ toList s   go (OneOf s) =@@ -129,9 +134,7 @@     in if Set.member emptyUsage s       then "[" <> contents (Set.delete emptyUsage s) <> "]"       else "(" <> contents s <> ")"-  describe (name, Flag _ desc) =-    let prefix = "--" <> name-    in if T.null desc then "" else "\n" <> prefix <> "\t" <> desc+  describe (name, Flag _ desc) = if T.null desc then "" else "\n" <> qualify name <> "\t" <> desc   details = T.concat $ fmap describe $ Map.toList flags  -- Parser definition errors.@@ -202,6 +205,8 @@ data FlagError   -- | A flag was declared multiple times.   = DuplicateFlag Name+  -- | The parser was empty.+  | EmptyParser   -- | The input included the @--help@ flag.   | Help Text   -- | At least one unary flag was specified multiple times with different values.@@ -214,6 +219,8 @@   -- last token or was followed by a value which is also a flag name (in which case you should use   -- the single-token form: @--flag=--value@).   | MissingFlagValue Name+  -- | A flag with a reserved name was declared.+  | ReservedFlag Name   -- | At least one flag was set but unused. This can happen when optional flags are set but their   -- branch is not selected.   | UnexpectedFlags (NonEmpty Name)@@ -223,22 +230,24 @@  -- Pretty-print a 'FlagError'. displayFlagError :: FlagError -> Text-displayFlagError (InconsistentFlagValues name) = "inconsistent values for --" <> name-displayFlagError (InvalidFlagValue name val msg) =-  "invalid value \"" <> val <> "\" for --" <> name <> " (" <> T.pack msg <> ")"-displayFlagError (DuplicateFlag name) = "--" <> name <> " was declared multiple times"+displayFlagError (DuplicateFlag name) = qualify name <> " was declared multiple times"+displayFlagError EmptyParser = "empty parser" displayFlagError (Help usage) = usage-displayFlagError (MissingFlag name) = "--" <> name <> " is required but was not set"-displayFlagError (MissingFlagValue name) = "missing value for --" <> name+displayFlagError (InconsistentFlagValues name) = "inconsistent values for " <> qualify name+displayFlagError (InvalidFlagValue name val msg) =+  "invalid value \"" <> val <> "\" for " <> qualify name <> " (" <> T.pack msg <> ")"+displayFlagError (MissingFlag name) = qualify name <> " is required but was not set"+displayFlagError (MissingFlagValue name) = "missing value for " <> qualify name+displayFlagError (ReservedFlag name) = qualify name <> " was declared but is reserved" displayFlagError (UnexpectedFlags names) =-  "unexpected " <> (T.intercalate " " $ fmap ("--" <>) $ toList $ names)-displayFlagError (UnknownFlag name) = "undeclared --" <> name+  "unexpected " <> (T.intercalate " " $ fmap qualify $ toList $ names)+displayFlagError (UnknownFlag name) = "undeclared " <> qualify name  -- Mark a flag as used. This is useful to check for unexpected flags after parsing is complete. useFlag :: Name -> Action () useFlag name = tell (Set.singleton name) >> modify (Set.insert name) --- | Returns a nullary parser with the given name and description.+-- | Returns a parser with the given name and description for a flag with no value. switch :: Name -> Description -> FlagParser Bool switch name desc = Actionable action flags usage where   action = do@@ -248,9 +257,10 @@   flags = Map.singleton name (Flag Nullary desc)   usage = emptyUsage `orElse` Exactly name --- | Returns a unary parser using the given parsing function, name, and description.-unaryFlag :: (Text -> Either String a) -> Name -> Description -> FlagParser a-unaryFlag convert name desc = Actionable action flags usage where+-- | Returns a parser using the given parsing function, name, and description for a flag with an+-- associated value.+flag :: (Text -> Either String a) -> Name -> Description -> FlagParser a+flag convert name desc = Actionable action flags usage where   action = do     useFlag name     asks (Map.lookup name) >>= \case@@ -263,29 +273,28 @@  -- | Returns a parser for a single text value. textFlag :: Name -> Description -> FlagParser Text-textFlag = unaryFlag Right+textFlag = flag Right  -- | Returns a parser for any value with a 'Read' instance. Prefer 'textFlag' for textual values -- since 'flag'  will expect its values to be double-quoted and might not work as expected.-flag :: Read a => Name -> Description -> FlagParser a-flag = unaryFlag (readEither . T.unpack)+autoFlag :: Read a => Name -> Description -> FlagParser a+autoFlag = flag (readEither . T.unpack)  -- | Returns a parser for a multiple text value.-repeatedTextFlag :: Text -> Name -> Description -> FlagParser [Text]-repeatedTextFlag sep =  unaryFlag $ Right . T.splitOn sep+textListFlag :: Text -> Name -> Description -> FlagParser [Text]+textListFlag sep =  flag $ Right . T.splitOn sep  -- | Returns a parser for multiple values with a 'Read' instance, with a configurable separator.-repeatedFlag :: Read a => Text -> Name -> Description -> FlagParser [a]-repeatedFlag sep = unaryFlag $ sequenceA . fmap (readEither . T.unpack) . T.splitOn sep--helpSwitch :: FlagParser Bool-helpSwitch = switch helpName "show usage and exit"+autoListFlag :: Read a => Text -> Name -> Description -> FlagParser [a]+autoListFlag sep = flag $ sequenceA . fmap (readEither . T.unpack) . T.splitOn sep --- Tries to gather all raw flag values into a map.-gatherValues :: Map Name Flag -> [String] -> Either FlagError ((Map Name Text), [String])-gatherValues flags = go where+-- Tries to gather all raw flag values into a map. When @ignoreUnknown@ is true, this function will+-- pass through any unknown flags into the returned argument list, otherwise it will throw a+-- 'FlagError'.+gatherValues :: Bool -> Map Name Flag -> [String] -> Either FlagError ((Map Name Text), [String])+gatherValues ignoreUnknown flags = go where   go [] = Right (Map.empty, [])-  go (token:tokens) = if not (isPrefixOf "--" token)+  go (token:tokens) = if not (prefix `isPrefixOf` token)     then second (token:) <$> go tokens     else       let entry = drop 2 token :: String@@ -303,34 +312,61 @@                   then Right (vals', args')                   else Left $ InconsistentFlagValues name           in case Map.lookup name flags of-            Nothing -> Left (UnknownFlag name)+            Nothing -> if ignoreUnknown+              then second (token:) <$> go tokens+              else Left (UnknownFlag name)             Just (Flag Nullary _) -> insert "" tokens             Just (Flag Unary _) -> case T.uncons pval of               Nothing -> case tokens of-                (token':tokens') -> if isPrefixOf "--" token'+                (token':tokens') -> if prefix `isPrefixOf` token'                   then missing                   else insert (T.pack token') tokens'                 _ -> missing               Just (_, val) -> insert val tokens +-- Runs a single parsing pass.+runAction :: Bool -> Action a -> Map Name Flag -> [String] -> Either FlagError (a, [String])+runAction ignoreUnknown action flags tokens = case gatherValues ignoreUnknown flags tokens of+  Left err -> Left err+  Right (values, args) -> case runExcept $ runRWST action values Set.empty of+    Right (rv, usedNames, readNames) ->+      let unused = Set.difference readNames usedNames+      in case Set.minView unused of+        Nothing -> Right (rv, args)+        Just (name, names) -> Left $ UnexpectedFlags $ name :| toList names+    Left (MissingValue name) -> Left $ MissingFlag name+    Left (InvalidValue name val msg) -> Left $ InvalidFlagValue name val msg++-- Preprocessing parser.+reservedParser :: FlagParser (Bool, Set Name, Set Name)+reservedParser =+  let setFlag name = Set.fromList <$> (flag (Right . T.splitOn ",") name "" <|> pure [])+  in (,,)+    <$> switch "help" ""+    <*> setFlag "swallowed_flags"+    <*> setFlag "swallowed_switches"+ -- | Runs a parser on a list of tokens, returning the parsed flags alongside other non-flag -- arguments (i.e. which don't start with @--@). If the special @--@ token is found, all following -- tokens will be considered arguments (even if they look like flags). parseFlags :: FlagParser a -> [String] -> Either FlagError (a, [String])-parseFlags parser tokens = case (,) <$> helpSwitch <*> parser of-  Invalid (Duplicate name) -> Left $ DuplicateFlag name-  Actionable action flags usage -> case gatherValues flags tokens of-    Left err -> Left err-    Right (values, args) -> case runExcept $ runRWST action values Set.empty of-      Right ((True, _), _, _) -> Left $ Help $ displayUsage flags usage-      Right ((False, res), usedNames, readNames) ->-        let unused = Set.difference readNames usedNames-        in case Set.minView unused of-          Nothing -> Right (res, args)-          Just (name, names) -> Left $ UnexpectedFlags $ name :| toList names-      Left (MissingValue name) -> Left $ MissingFlag name-      Left (InvalidValue name val msg) -> Left $ InvalidFlagValue name val msg-  _ -> error "unreachable" -- The parser can never be empty.+parseFlags parser tokens = case reservedParser of+  Invalid _ -> error "unreachable"+  Actionable action0 flags0 _ -> do+    ((showHelp, swallowedFlags, swallowedSwitches), tokens') <- runAction True action0 flags0 tokens+    (action, flags) <- case parser of+      Invalid (Duplicate name) -> Left $ DuplicateFlag name+      Invalid Empty -> Left EmptyParser+      Actionable action flags usage -> do+        case Set.lookupMin (Map.keysSet $ Map.intersection flags0 flags) of+          Nothing -> Right ()+          Just name -> Left $ ReservedFlag name+        when showHelp $  Left (Help $ displayUsage flags usage)+        let+          flags' = foldl' (\m name -> Map.insert name (Flag Unary "") m) flags swallowedFlags+          flags'' = foldl' (\m name -> Map.insert name (Flag Nullary "") m) flags' swallowedSwitches+        Right (action, flags'')+    runAction False action flags tokens'  -- | Runs a parser on the system's arguments, or exits with code 1 and prints the relevant error -- message in case of failure.

@@ -32,7 +32,7 @@       res `shouldBe` Left (UnexpectedFlags ("foo" :| []))     it "should branch correctly with unary flags" $ do       let-        parser = (Right <$> flag @String "ok" "") <|> (Left <$> flag @String "fail" "")+        parser = (Right <$> autoFlag @String "ok" "") <|> (Left <$> autoFlag @String "fail" "")         res = parseFlags parser ["--ok", "\"yes\"", "no"]       res `shouldBe` Right (Right "yes", ["no"])     it "should branch correctly with nullary flags" $ do@@ -47,6 +47,11 @@       res `shouldBe` Left (InconsistentFlagValues "foo")     it "should support the same flag value multiple times" $ do       let-        parser = flag @Int "foo" ""+        parser = autoFlag @Int "foo" ""         res = parseFlags parser ["--foo=1", "--foo=1"]       res `shouldBe` Right (1, [])+    it "should support text lists" $ do+      let+        parser = textListFlag "," "bar" ""+        res = parseFlags parser ["--bar=a,b,c", "def"]+      res `shouldBe` Right (["a", "b", "c"], ["def"])