flags-applicative 0.0.1.0 → 0.0.2.0

raw patch · 4 files changed

+206/−120 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 +6/−6
• flags-applicative.cabal +1/−1
• src/Flags/Applicative.hs +192/−106
• test/Spec.hs +7/−7

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

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

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

@@ -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, [])