diff --git a/app/SimpleExample.hs b/app/SimpleExample.hs --- a/app/SimpleExample.hs +++ b/app/SimpleExample.hs @@ -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 diff --git a/flags-applicative.cabal b/flags-applicative.cabal --- a/flags-applicative.cabal +++ b/flags-applicative.cabal @@ -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 diff --git a/src/Flags/Applicative.hs b/src/Flags/Applicative.hs --- a/src/Flags/Applicative.hs +++ b/src/Flags/Applicative.hs @@ -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. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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"])