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.5.2 +version: 0.1.0.0 synopsis: Applicative flag parsing description: https://github.com/mtth/flags-applicative homepage: https://github.com/mtth/flags-applicative @@ -19,10 +19,11 @@ Flags.Applicative build-depends: base >= 4.8 && < 5 - , containers >= 0.6 && < 0.7 - , mtl >= 2.2 && < 2.3 - , network >= 2.8 && < 2.9 - , text >= 1.2 && < 1.3 + , casing >= 0.1.4 + , containers >= 0.6 + , mtl >= 2.2 + , network >= 2.8 + , text >= 1.2 default-language: Haskell2010 ghc-options: -Wall @@ -34,8 +35,9 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.8 && <5 - , text >= 1.2 && < 1.3 - , hspec >=2.6 && <2.7 + , containers >= 0.6 + , text >= 1.2 + , hspec >=2.6 , flags-applicative default-language: Haskell2010 diff --git a/src/Flags/Applicative.hs b/src/Flags/Applicative.hs --- a/src/Flags/Applicative.hs +++ b/src/Flags/Applicative.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -- | This module implements a lightweight flags parser, inspired by @optparse-applicative@. -- @@ -14,32 +15,37 @@ -- import Data.Text (Text) -- import Flags.Applicative -- --- data Options = Options +-- data Flags = Flags -- { rootPath :: Text -- , logLevel :: Int -- , context :: Maybe Text -- } deriving Show -- --- optionsParser :: FlagsParser Options --- optionsParser = Options \<$\> textFlag "root" "path to the root" --- \<*\> (autoFlag "log_level" "" \<|\> pure 0) --- \<*\> (optional $ textFlag "context" "") +-- flagsParser :: FlagsParser Flags +-- flagsParser = Flags +-- \<$\> flag textVal "root" "path to the root" +-- \<*\> (flag autoVal "log_level" "" \<|\> pure 0) +-- \<*\> (optional $ flag textVal "context" "") -- -- main :: IO () -- main = do --- (opts, args) <- parseSystemFlagsOrDie optionsParser --- print opts +-- (flags, args) <- parseSystemFlagsOrDie optionsParser +-- print flags -- @ module Flags.Applicative ( - -- * Types - Name, Description, FlagsParser, FlagError(..), - -- * Running parsers - parseFlags, parseSystemFlagsOrDie, -- * Declaring flags + Name, Description, -- ** Nullary flags switch, boolFlag, -- ** Unary flags - flag, textFlag, hostFlag, autoFlag, textListFlag, autoListFlag + flag, Reader, + -- *** Common readers + autoVal, textVal, fracVal, intVal, enumVal, hostVal, + -- *** Reader combinators + listOf, mapOf, + -- * Running parsers + FlagsParser, FlagsError(..), + parseFlags, parseSystemFlagsOrDie ) where import Control.Applicative ((<|>), Alternative, empty) @@ -59,9 +65,11 @@ import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Read as T import Network.Socket (HostName, PortNumber) import System.Exit (die) import System.Environment (getArgs) +import Text.Casing (fromHumps, toScreamingSnake) import Text.Read (readEither) -- The prefix used to identify all flags. @@ -155,10 +163,9 @@ -- There are two types of flags: -- -- * Nullary flags created with 'switch' and 'boolFlag', which do not accept a value. --- * Unary flags created with 'flag' and its convenience variants (e.g. 'textFlag', 'autoFlag', --- 'autoListFlag'). 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. +-- * Unary flags created with 'flag'. 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' or 'parseSystemFlagsOrDie'. data FlagsParser a @@ -212,7 +219,7 @@ pure res -- | The possible parsing errors. -data FlagError +data FlagsError = DuplicateFlag Name -- ^ A flag was declared multiple times. | EmptyParser @@ -244,7 +251,7 @@ displayFlags = T.intercalate " " . fmap qualify . toList -- Pretty-print a 'FlagError'. -displayFlagError :: FlagError -> Text +displayFlagError :: FlagsError -> Text displayFlagError (DuplicateFlag name) = qualify name <> " was declared multiple times" displayFlagError EmptyParser = "empty parser" displayFlagError (Help usage) = usage @@ -279,9 +286,12 @@ boolFlag :: Name -> Description -> FlagsParser Bool boolFlag name desc = (True <$ switch name desc) <|> pure False --- | Returns a parser using the given parsing function, name, and description for a flag with an +-- | The type used to read flag values. +type Reader a = Text -> Either String a + +-- | Returns a parser using the given value reader, name, and description for a flag with an -- associated value. -flag :: (Text -> Either String a) -> Name -> Description -> FlagsParser a +flag :: Reader a -> Name -> Description -> FlagsParser a flag convert name desc = Actionable action flags usage where action = do useFlag name @@ -293,39 +303,79 @@ flags = Map.singleton name (Flag Unary desc) usage = Exactly name --- | Returns a parser for a single text value. -textFlag :: Name -> Description -> FlagsParser Text -textFlag = flag Right +-- | Returns a reader for any value with a 'Read' instance. Prefer 'textVal' for textual values +-- since 'autoVal' will expect its values to be double-quoted and might not work as expected. +autoVal :: Read a => Reader a +autoVal = readEither . T.unpack --- | Returns a parser for network hosts of the form @hostname:port@. The port part is optional. -hostFlag :: Name -> Description -> FlagsParser (HostName, Maybe PortNumber) -hostFlag = flag $ \txt -> do +-- | Returns a reader for a single text value. +textVal :: Reader Text +textVal = Right + +-- Fully executes a reader. This function is useful for interacting with "Data.Text.Read". +readingFully :: (Text -> Either String (a, Text)) -> Reader a +readingFully f t = case f t of + Left e -> Left e + Right (v, t') -> if T.null t' then Right v else Left $ T.unpack $ "trailing chars: " <> t' + +-- | Returns a reader for any number with a 'Fractional' instance (e.g. 'Double', 'Float'). +fracVal :: Fractional a => Reader a +fracVal = readingFully T.rational + +-- | Returns a reader for any number with an 'Integral instance (e.g. 'Int', 'Integer'). +intVal :: Integral a => Reader a +intVal = readingFully $ T.signed T.decimal + +-- | Returns a reader for 'Enum' instances. This reader assumes that enum (Haskell) constructors are +-- written in PascalCase and expects UPPER_SNAKE_CASE as command-line flag values. For example: +-- +-- > data Mode = Flexible | Strict deriving (Bounded, Enum, Show) +-- > modeFlag = flag enumVal "mode" "the mode" :: FlagsParser Mode +-- +-- The above flag will accept values @--mode=FLEXIBLE@ and @--mode=STRICT@. +enumVal :: (Bounded a, Enum a, Show a) => Reader a +enumVal = parse where + write = T.pack . toScreamingSnake . fromHumps . show -- Serializes an enum value. + m = Map.fromList $ fmap (\v -> (write v, v)) [minBound .. maxBound] + parse t = case Map.lookup t m of + Nothing -> + let e = t <> " is not in " <> T.intercalate "," (Map.keys m) + in Left $ T.unpack e + Just v -> Right v + +-- | Returns a reader for network hosts of the form @hostname:port@. The port part is optional. +hostVal :: Reader (HostName, Maybe PortNumber) +hostVal txt = do let (hostname, suffix) = T.breakOn ":" txt mbPort <- case T.stripPrefix ":" suffix of Nothing -> Right Nothing Just portStr -> Just <$> readEither (T.unpack portStr) pure (T.unpack hostname, mbPort) --- | Returns a parser for any value with a 'Read' instance. Prefer 'textFlag' for textual values --- since 'autoFlag' will expect its values to be double-quoted and might not work as expected. -autoFlag :: Read a => Name -> Description -> FlagsParser a -autoFlag = flag (readEither . T.unpack) - --- | Returns a parser for a single flag with multiple text values. -textListFlag :: Text -> Name -> Description -> FlagsParser [Text] -textListFlag sep = flag $ Right . T.splitOn sep +-- | Transforms a single-valued unary flag into one which accepts multiple comma-separated values. +-- For example, to parse a comma-separated list of integers: +-- +-- > countsFlag = flag (listOf intVal) "counts" "the counts" +-- +-- Empty text values are ignored, which means both that trailing commas are supported and that an +-- empty list can be specified simply by specifying an empty value on the command line. Note that +-- escapes are not supported, so values should not contain any commas. +listOf :: Reader a -> Reader [a] +listOf f = traverse f . filter (not . T.null) . T.splitOn "," --- | Returns a parser for a single flag with multiple values having a 'Read' instance, with a --- configurable separator. Empty values are always ignored, so it's possible to declare an empty --- list as @--list=@ and trailing commas are supported. -autoListFlag :: Read a => Text -> Name -> Description -> FlagsParser [a] -autoListFlag sep = - flag $ sequenceA . fmap (readEither . T.unpack) . filter (not . T.null) . T.splitOn sep +-- | Transforms a single-valued unary flag into one which accepts a comma-separated list of +-- colon-delimited key-value pairs. The syntax is @key:value[,key:value...]@. Note that escapes are +-- not supported, so neither keys not values should contain colons or commas. +mapOf :: Ord a => Reader a -> Reader b -> Reader (Map a b) +mapOf f g = fmap Map.fromList <$> listOf (h . T.breakOn ":") where + h (k, v) = case T.uncons v of + Nothing -> Left $ T.unpack $ "empty value for key " <> k + Just (_, v') -> (,) <$> f k <*> g v' -- 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( and pass through any @--@ value), -- otherwise it will throw a 'FlagError'. -gatherValues :: Bool -> Map Name Flag -> [String] -> Either FlagError ((Map Name Text), [String]) +gatherValues :: Bool -> Map Name Flag -> [String] -> Either FlagsError ((Map Name Text), [String]) gatherValues ignoreUnknown flags = go where go [] = Right (Map.empty, []) go (token:tokens) = if not (prefix `isPrefixOf` token) @@ -361,7 +411,7 @@ Just (_, val) -> insert val tokens -- Runs a single parsing pass. -runAction :: Bool -> Action a -> Map Name Flag -> [String] -> Either FlagError (a, Set Name, [String]) +runAction :: Bool -> Action a -> Map Name Flag -> [String] -> Either FlagsError (a, Set Name, [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 @@ -383,7 +433,7 @@ -- | 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 :: FlagsParser a -> [String] -> Either FlagError (a, [String]) +parseFlags :: FlagsParser a -> [String] -> Either FlagsError (a, [String]) parseFlags parser tokens = case reservedParser of Invalid _ -> error "unreachable" Actionable action0 flags0 _ -> do diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,101 +3,132 @@ import Control.Applicative ((<|>), optional) import Data.Either (isLeft) +import Data.Foldable (asum) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) import Test.Hspec (describe, expectationFailure, hspec, it, shouldBe) import Flags.Applicative +data Mode = Flexible | Strict deriving (Bounded, Enum, Eq, Show) + main :: IO () main = hspec $ do describe "parse" $ do it "should parse a single flag" $ do let - parser = textFlag "foo" "" + parser = flag textVal "foo" "" res = parseFlags parser ["--foo=abc", "hi"] res `shouldBe` Right ("abc", ["hi"]) + it "should fail on duplicate flag" $ do let - parser = (,) <$> textFlag "foo" "" <*> textFlag "foo" "" + parser = (,) <$> flag textVal "foo" "" <*> flag textVal "foo" "" res = parseFlags parser [] res `shouldBe` Left (DuplicateFlag "foo") + it "should support help" $ do let - parser = textFlag "foo" "" + parser = flag textVal "foo" "" res = parseFlags parser ["--foo=abc", "hi", "--help"] isLeft res `shouldBe` True + it "should fail on unknown flags" $ do let - parser = textFlag "foo" "" + parser = flag textVal "foo" "" res = parseFlags parser ["hi", "--bar"] res `shouldBe` Left (UnknownFlag "bar") + it "should detect unexpected flags" $ do let 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 <$> autoFlag @String "ok" "") <|> (Left <$> autoFlag @String "fail" "") + parser = asum + [ Right <$> flag (autoVal @String) "ok" "" + , Left <$> flag (autoVal @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 <$ 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 let - parser = textFlag "foo" "" + parser = flag textVal "foo" "" res = parseFlags parser ["--foo=1", "--foo=2"] res `shouldBe` Left (InconsistentFlagValues "foo") + it "should support the same flag value multiple times" $ do let - parser = autoFlag @Int "foo" "" + parser = flag (autoVal @Int) "foo" "" res = parseFlags parser ["--foo=1", "--foo=1"] res `shouldBe` Right (1, []) + it "should support text lists" $ do let - parser = textListFlag "," "bar" "" + parser = flag (listOf textVal) "bar" "" res = parseFlags parser ["--bar=a,b,c", "def"] res `shouldBe` Right (["a", "b", "c"], ["def"]) + + it "should support maps" $ do + let + parser = flag (mapOf textVal fracVal) "bar" "" :: FlagsParser (Map Text Double) + res = parseFlags parser ["--bar=a:1,b:0,c:2.5"] + res `shouldBe` Right (Map.fromList [("a", 1), ("b", 0), ("c", 2.5)], []) + it "should swallow switches" $ do let parser = boolFlag "foo" "" res = parseFlags parser ["--foo", "--bar", "--swallowed_switches=bar"] res `shouldBe` Right (True, []) + it "should fail when a switch is set as a flag" $ do let parser = boolFlag "foo" "" res = parseFlags parser ["--foo=3"] res `shouldBe` Left (UnexpectedFlagValue "foo") + it "should swallow flags" $ do let parser = boolFlag "foo" "" res = parseFlags parser ["--bar=2", "--swallowed_flags=bar"] res `shouldBe` Right (False, []) + it "should fail when a flag is swallowed as a switch" $ do let parser = boolFlag "foo" "" res = parseFlags parser ["--foo", "--bar=1", "--swallowed_switches=bar"] res `shouldBe` Left (UnexpectedFlagValue "bar") + it "should parse a hostname" $ do let - parser = hostFlag "host" "" + parser = flag hostVal "host" "" res = parseFlags parser ["--host=foo.com"] res `shouldBe` Right (("foo.com", Nothing), []) + it "should parse a hostname and a port" $ do let - parser = hostFlag "host" "" + parser = flag hostVal "host" "" res = parseFlags parser ["--host=localhost:1234"] res `shouldBe` Right (("localhost", Just 1234), []) + it "should fail when given an invalid port" $ do let - parser = hostFlag "host" "" + parser = flag hostVal "host" "" res = parseFlags parser ["--host=localhost:1a2"] case res of Left (InvalidFlagValue "host" _ _) -> pure () _ -> expectationFailure $ show res + it "should report all missing required flags" $ do let parser = switch "foo" "" <|> switch "bar" "" @@ -105,13 +136,44 @@ case res of Left (MissingFlags ("foo" :| ["bar"])) -> pure () _ -> expectationFailure $ show res + it "should ignore conflicting flags after --" $ do let parser = switch "foo" "" <|> switch "bar" "" res = parseFlags parser ["--foo", "--", "--bar"] res `shouldBe` Right ((), ["--bar"]) + it "should ignore undeclared flags after --" $ do let - parser = optional $ textFlag "foo" "" + parser = optional $ flag textVal "foo" "" res = parseFlags parser ["--", "--bar=2"] res `shouldBe` Right (Nothing, ["--bar=2"]) + + it "should parse integral flags" $ do + let parser = flag intVal "int" "" :: FlagsParser Int + parseFlags parser ["--int=12"] `shouldBe` Right (12, []) + parseFlags parser ["--int=-1"] `shouldBe` Right (-1, []) + parseFlags parser ["--int", "0"] `shouldBe` Right (0, []) + case parseFlags parser ["--int", "0.1"] of + Left (InvalidFlagValue "int" "0.1" _) -> pure () + r -> expectationFailure $ show r + case parseFlags parser ["--int", ""] of + Left (InvalidFlagValue "int" "" _) -> pure () + r -> expectationFailure $ show r + + it "should parse fractional flags" $ do + let parser = flag fracVal "double" "" :: FlagsParser Double + parseFlags parser ["--double=12.1"] `shouldBe` Right (12.1, []) + parseFlags parser ["--double=-1"] `shouldBe` Right (-1, []) + parseFlags parser ["--double", "0"] `shouldBe` Right (0, []) + case parseFlags parser ["--double", "0."] of + Left (InvalidFlagValue "double" "0." _) -> pure () + r -> expectationFailure $ show r + + it "should parse enum flags" $ do + let parser = flag enumVal "mode" "" :: FlagsParser Mode + parseFlags parser ["--mode", "FLEXIBLE"] `shouldBe` Right (Flexible, []) + parseFlags parser ["--mode=STRICT"] `shouldBe` Right (Strict, []) + case parseFlags parser ["--mode", "NONE"] of + Left (InvalidFlagValue "mode" "NONE" _) -> pure () + r -> expectationFailure $ show r