diff --git a/app/SimpleExample.hs b/app/SimpleExample.hs --- a/app/SimpleExample.hs +++ b/app/SimpleExample.hs @@ -4,7 +4,7 @@ import Control.Applicative ((<|>), optional) import Data.Text (Text, pack) -import Data.Text.Read (decimal) +import Data.Text.Read (decimal, double) import Flags.Applicative import System.Environment (getArgs) @@ -12,14 +12,14 @@ { rootPath :: Text , logLevel :: Int , context :: Maybe Text + , values :: [Double] } deriving Show optionsParser :: FlagParser Options -optionsParser = Options <$> textFlag "root" "path to the root" - <*> (numericFlag decimal "log_level" "" <|> pure 0) +optionsParser = Options <$> (textFlag "root" "path to the root" <|> textFlag "url" "") + <*> (flag "log_level" "" <|> pure 0) <*> (optional $ textFlag "context" "") + <*> (repeatedFlag "," "values" "" <|> pure []) main :: IO () -main = do - args <- getArgs - print $ parseFlags optionsParser args +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.1.0 +version: 0.0.2.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 @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -- | Simple flags parsing module, inspired by @optparse-applicative@. -- @@ -13,9 +12,7 @@ -- -- import Control.Applicative ((\<|\>), optional) -- import Data.Text (Text) --- import Data.Text.Read (decimal) -- import Flags.Applicative --- import System.Environment (getArgs) -- -- data Options = Options -- { rootPath :: Text @@ -25,24 +22,22 @@ -- -- optionsParser :: FlagParser Options -- optionsParser = Options \<$\> textFlag "root" "path to the root" --- \<*\> (numericFlag decimal "log_level" "" \<|\> pure 0) +-- \<*\> (flag "log_level" "" \<|\> pure 0) -- \<*\> (optional $ textFlag "context" "") -- -- main :: IO () -- main = do --- args <- getArgs --- print $ parseFlags optionsParser args +-- (opts, args) <- parseSystemFlagsOrDie optionsParser +-- print opts -- @ -- TODO: Add @--help@ support. module Flags.Applicative - ( Name, FlagParser, FlagError(..), ParserError(..) - , parseFlags - -- * Nullary flags - , boolFlag - -- * Unary flags - , unaryFlag, textFlag, numericFlag + ( Name, Description, FlagParser, FlagError(..) + , parseFlags, parseSystemFlagsOrDie + -- * Defining flags + , switch, unaryFlag, textFlag, flag, repeatedTextFlag, repeatedFlag ) where import Control.Applicative ((<|>), Alternative, empty, optional) @@ -54,24 +49,38 @@ import Control.Monad.Writer.Strict (tell) import Data.Bifunctor (first, second) import Data.Foldable (toList) +import Data.List (isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map) import Data.Maybe (isJust) import Data.Set (Set) import Data.Text (Text) +import System.Exit (die) import System.Environment (getArgs) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Text.Read as T +import Text.Read (readEither) --- | The name of a flag, can use all characters but @=@ (the value delimiter). It's good practice --- for flag names to be lowercase ASCII with underscores. +-- | 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 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. type Name = Text +-- The name of the help switch. +helpName :: Name +helpName = "help" + +-- | An human-readable explanation of what the flag does. +type Description = Text + data Arity = Nullary | Unary deriving Eq -data Flag = Flag Arity Text +data Flag = Flag Arity Description -- The errors which can happen during flag parsing. data ValueError @@ -85,26 +94,66 @@ (Except ValueError) -- Eventual parsing error. a --- | Parser definition errors. +data Usage + = Exactly Name + | AllOf (Set Usage) + | OneOf (Set Usage) + deriving (Eq, Ord) + +emptyUsage :: Usage +emptyUsage = AllOf Set.empty + +andAlso :: Usage -> Usage -> Usage +andAlso (AllOf s1) (AllOf s2) = AllOf $ s1 <> s2 +andAlso (AllOf s) u = AllOf $ Set.insert u s +andAlso u (AllOf s) = AllOf $ Set.insert u s +andAlso u1 u2 = AllOf $ Set.fromList [u1, u2] + +orElse :: Usage -> Usage -> Usage +orElse (OneOf s1) (OneOf s2) = OneOf $ s1 <> s2 +orElse (OneOf s) u = OneOf $ Set.insert u s +orElse u (OneOf s) = OneOf $ Set.insert u s +orElse u1 u2 = OneOf $ Set.fromList [u1, u2] + +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 (AllOf s) = + T.intercalate " " $ fmap go $ filter (/= emptyUsage) $ toList s + go (OneOf s) = + let contents s' = T.intercalate "|" $ fmap go $ toList $ s' + 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 + details = T.concat $ fmap describe $ Map.toList flags + +-- Parser definition errors. data ParserError - = DuplicateFlag Name -- ^ The same flag name was declared multiple times. - | Empty -- ^ The parser is empty (this should not happen if you use standard combinators). + = Duplicate Name + | Empty deriving (Eq, Show) -- | Flags parser. -- -- There are two types of flags: -- --- * Nullary flags created with 'boolFlag' which are 'True' when set and 'False' otherwise (a.k.a. --- switches). For example @--version@ or @--enable_foo@. --- * Unary flags created with 'unaryFlag' and its convenience variants (e.g. 'textFlag', --- 'numericFlag'). These expect a value to be passed in either after an equal sign (@--foo=value@) +-- * Nullary flags created with 'switch which are 'True' when set and 'False' otherwise. For example +-- @--version@ or @--enable_foo@. +-- * Unary flags created with 'unaryFlag' and its convenience variants (e.g. 'textFlag', 'flag', +-- 'repeatedFlag'). These expect a value to be passed in either after an equal sign (@--foo=value@) -- or as the following input value (@--foo value@). If the value starts with @--@, only the first -- form is accepted. -- -- You can run a parser using 'parseFlags'. data FlagParser a - = Actionable (Action a) (Map Name Flag) + = Actionable (Action a) (Map Name Flag) Usage | Invalid ParserError deriving Functor @@ -116,14 +165,14 @@ Nothing -> Right $ flags1 `Map.union` flags2 instance Applicative FlagParser where - pure res = Actionable (pure res) Map.empty + pure res = Actionable (pure res) Map.empty emptyUsage Invalid err <*> _ = Invalid err _ <*> Invalid err = Invalid err - Actionable action1 flags1 <*> Actionable action2 flags2 = + Actionable action1 flags1 usage1 <*> Actionable action2 flags2 usage2 = case mergeFlags flags1 flags2 of - Left name -> Invalid $ DuplicateFlag name - Right flags -> Actionable (action1 <*> action2) flags + Left name -> Invalid $ Duplicate name + Right flags -> Actionable (action1 <*> action2) flags (usage1 `andAlso` usage2) instance Alternative FlagParser where empty = Invalid Empty @@ -132,31 +181,33 @@ parser <|> Invalid Empty = parser Invalid err <|> _ = Invalid err _ <|> Invalid err = Invalid err - Actionable action1 flags1 <|> Actionable action2 flags2 = case mergeFlags flags1 flags2 of - Left name -> Invalid $ DuplicateFlag name - Right flags -> Actionable action flags where - wrap action = catchError (Just <$> action) $ \case - (MissingValue _) -> pure Nothing - err -> throwError err - action = do - used <- get - wrap action1 >>= \case - Nothing -> put used >> action2 - Just res -> do - used' <- get - _ <- wrap action2 - put used' - pure res + Actionable action1 flags1 usage1 <|> Actionable action2 flags2 usage2 = + case mergeFlags flags1 flags2 of + Left name -> Invalid $ Duplicate name + Right flags -> Actionable action flags (usage1 `orElse` usage2) where + wrap action = catchError (Just <$> action) $ \case + (MissingValue _) -> pure Nothing + err -> throwError err + action = do + used <- get + wrap action1 >>= \case + Nothing -> put used >> action2 + Just res -> do + used' <- get + _ <- wrap action2 + put used' + pure res -- | The possible parsing errors. data FlagError + -- | A flag was declared multiple times. + = DuplicateFlag Name + -- | The input included the @--help@ flag. + | Help Text -- | At least one unary flag was specified multiple times with different values. - = InconsistentFlagValues Name + | InconsistentFlagValues Name -- | A unary flag's value failed to parse. | InvalidFlagValue Name Text String - -- | The parser is invalid. Unlike other 'FlagError' constructors, this indicates an issue with - -- the parser's declaration (rather than the input tokens). - | InvalidParser ParserError -- | A required flag was missing. | MissingFlag Name -- | A unary flag was missing a value. This can happen either if a value-less unary flag was the @@ -170,67 +221,36 @@ | UnknownFlag Name deriving (Eq, Show) --- Tries to gather all raw flag values into a map. -gatherValues :: Map Name Flag -> [Text] -> Either FlagError ((Map Name Text), [Text]) -gatherValues flags = go where - go [] = Right (Map.empty, []) - go (token:tokens) = case T.stripPrefix "--" token of - Nothing -> second (token:) <$> go tokens - Just "" -> Right (Map.empty, tokens) - Just suffix -> - let - (name, pval) = T.breakOn "=" suffix - missing = Left $ MissingFlagValue name - insert val tokens' = do - (vals', args') <- go tokens' - case Map.lookup name vals' of - Nothing -> Right (Map.insert name val vals', args') - Just val' -> if val == val' - then Right (vals', args') - else Left $ InconsistentFlagValues name - in case Map.lookup name flags of - Nothing -> Left (UnknownFlag name) - Just (Flag Nullary _) -> insert "" tokens - Just (Flag Unary _) -> case T.uncons pval of - Nothing -> case tokens of - (token':tokens') -> if T.isPrefixOf "--" token' - then missing - else insert token' tokens' - _ -> missing - Just (_, val) -> insert val tokens - --- | 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, [Text]) -parseFlags parser tokens = case parser of - Invalid err -> Left $ InvalidParser err - Actionable action flags -> case gatherValues flags (fmap T.pack tokens) of - Left err -> Left err - Right (values, args) -> case runExcept $ runRWST action values Set.empty of - Right (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 +-- 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 (Help usage) = usage +displayFlagError (MissingFlag name) = "--" <> name <> " is required but was not set" +displayFlagError (MissingFlagValue name) = "missing value for --" <> name +displayFlagError (UnexpectedFlags names) = + "unexpected " <> (T.intercalate " " $ fmap ("--" <>) $ toList $ names) +displayFlagError (UnknownFlag name) = "undeclared --" <> 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. -boolFlag :: Name -> Text -> FlagParser Bool -boolFlag name desc = Actionable action flags where +switch :: Name -> Description -> FlagParser Bool +switch name desc = Actionable action flags usage where action = do present <- asks (Map.member name) when present $ useFlag name pure present 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 -> Text -> FlagParser a -unaryFlag convert name desc = Actionable action flags where +unaryFlag :: (Text -> Either String a) -> Name -> Description -> FlagParser a +unaryFlag convert name desc = Actionable action flags usage where action = do useFlag name asks (Map.lookup name) >>= \case @@ -239,16 +259,82 @@ Left err -> throwError $ InvalidValue name val err Right res -> pure res flags = Map.singleton name (Flag Unary desc) + usage = Exactly name --- | Returns a flag with 'Text' values. -textFlag :: Name -> Text -> FlagParser Text +-- | Returns a parser for a single text value. +textFlag :: Name -> Description -> FlagParser Text textFlag = unaryFlag Right --- | Returns a flag which can parse numbers using the helper methods in "Data.Text.Read" (e.g. --- 'Data.Text.Read.decimal'). -numericFlag :: T.Reader a -> Name -> Text -> FlagParser a -numericFlag reader = unaryFlag go where - go val = case reader val of - Right (res, "") -> Right res - Left msg -> Left msg - _ -> Left "trailing value data" +-- | 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) + +-- | Returns a parser for a multiple text value. +repeatedTextFlag :: Text -> Name -> Description -> FlagParser [Text] +repeatedTextFlag sep = unaryFlag $ 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" + +-- 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 + go [] = Right (Map.empty, []) + go (token:tokens) = if not (isPrefixOf "--" token) + then second (token:) <$> go tokens + else + let entry = drop 2 token :: String + in if entry == "" + then Right (Map.empty, tokens) + else + let + (name, pval) = T.breakOn "=" (T.pack entry) + missing = Left $ MissingFlagValue name + insert val tokens' = do + (vals', args') <- go tokens' + case Map.lookup name vals' of + Nothing -> Right (Map.insert name val vals', args') + Just val' -> if val == val' + then Right (vals', args') + else Left $ InconsistentFlagValues name + in case Map.lookup name flags of + Nothing -> 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' + then missing + else insert (T.pack token') tokens' + _ -> missing + Just (_, val) -> insert val tokens + +-- | 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. + +-- | Runs a parser on the system's arguments, or exits with code 1 and prints the relevant error +-- message in case of failure. +parseSystemFlagsOrDie :: FlagParser a -> IO (a, [String]) +parseSystemFlagsOrDie parser = parseFlags parser <$> getArgs >>= \case + Left err -> die $ T.unpack $ displayFlagError err + Right res -> pure res diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} import Control.Applicative ((<|>)) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Text.Read (decimal) import Flags.Applicative import Test.Hspec import Test.Hspec.QuickCheck @@ -19,7 +19,7 @@ let parser = (,) <$> textFlag "foo" "" <*> textFlag "foo" "" res = parseFlags parser [] - res `shouldBe` Left (InvalidParser $ DuplicateFlag "foo") + res `shouldBe` Left (DuplicateFlag "foo") it "should fail on unknown flags" $ do let parser = textFlag "foo" "" @@ -27,17 +27,17 @@ res `shouldBe` Left (UnknownFlag "bar") it "should detect unexpected flags" $ do let - parser = boolFlag "bar" "" <|> boolFlag "foo" "" + parser = switch "bar" "" <|> switch "foo" "" res = parseFlags parser ["--bar", "--foo"] res `shouldBe` Left (UnexpectedFlags ("foo" :| [])) it "should branch correctly with unary flags" $ do let - parser = (Right <$> textFlag "ok" "") <|> (Left <$> textFlag "fail" "") - res = parseFlags parser ["--ok", "yes", "no"] + parser = (Right <$> flag @String "ok" "") <|> (Left <$> flag @String "fail" "") + res = parseFlags parser ["--ok", "\"yes\"", "no"] res `shouldBe` Right (Right "yes", ["no"]) it "should branch correctly with nullary flags" $ do let - parser = (True <$ boolFlag "true" "") <|> (False <$ boolFlag "false" "") + parser = (True <$ switch "true" "") <|> (False <$ switch "false" "") res = parseFlags parser ["--true", "b", "a"] res `shouldBe` Right (True, ["b", "a"]) it "should fail on inconsistent flag values" $ do @@ -47,6 +47,6 @@ res `shouldBe` Left (InconsistentFlagValues "foo") it "should support the same flag value multiple times" $ do let - parser = numericFlag decimal "foo" "" :: FlagParser Int + parser = flag @Int "foo" "" res = parseFlags parser ["--foo=1", "--foo=1"] res `shouldBe` Right (1, [])