flags-applicative (empty) → 0.0.1.0

raw patch · 7 files changed

+432/−0 lines, 7 filesdep +basedep +containersdep +flags-applicativesetup-changed

Dependencies added: base, containers, flags-applicative, hspec, mtl, text

Files

LICENSE +30/−0
README.md +20/−0
Setup.hs +2/−0
app/SimpleExample.hs +25/−0
flags-applicative.cabal +49/−0
src/Flags/Applicative.hs +254/−0
test/Spec.hs +52/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Matthieu Monsch (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Matthieu Monsch nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,20 @@+# Applicative flags++Simple flags parsing, inspired by+[`optparse-applicative`](http://hackage.haskell.org/package/optparse-applicative):++```haskell+data Options = Options+  { rootPath :: Text+  , logLevel :: Int+  , context :: Maybe Text+  } deriving Show++optionsParser :: FlagParser Options+optionsParser = Options <$> textFlag "root" "path to the root"+                        <*> (numericFlag decimal "log_level" "" <|> pure 0)+                        <*> (optional $ textFlag "context" "")+```++See the [documentation](http://hackage.haskell.org/package/flags-applicative)+for more information.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/SimpleExample.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative ((<|>), optional)+import Data.Text (Text, pack)+import Data.Text.Read (decimal)+import Flags.Applicative+import System.Environment (getArgs)++data Options = Options+  { rootPath :: Text+  , logLevel :: Int+  , context :: Maybe Text+  } deriving Show++optionsParser :: FlagParser Options+optionsParser = Options <$> textFlag "root" "path to the root"+                        <*> (numericFlag decimal "log_level" "" <|> pure 0)+                        <*> (optional $ textFlag "context" "")++main :: IO ()+main = do+  args <- getArgs+  print $ parseFlags optionsParser args

+ flags-applicative.cabal view

@@ -0,0 +1,49 @@+name:                flags-applicative+version:             0.0.1.0+synopsis:            Applicative flag parsing+description:         https://github.com/mtth/flags-applicative+homepage:            https://github.com/mtth/flags-applicative+license:             BSD3+license-file:        LICENSE+author:              Matthieu Monsch+maintainer:          matthieu.monsch@gmail.com+copyright:           2019 Matthieu Monsch+category:            Web+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md++library+  hs-source-dirs:      src+  exposed-modules:     Flags.Applicative+  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.6 && < 0.7+                     , mtl >= 2.2 && < 2.3+                     , text >= 1.2 && < 1.3+  default-language:    Haskell2010++test-suite flags-applicative-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , text >= 1.2 && < 1.3+    , hspec >=2.6 && <2.7+    , flags-applicative+  default-language: Haskell2010++executable simple-example+  hs-source-dirs:      app+  main-is:             SimpleExample.hs+  build-depends:+      base >=4.7 && <5+    , text >= 1.2 && < 1.3+    , flags-applicative+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/mtth/flags-applicative

+ src/Flags/Applicative.hs view

@@ -0,0 +1,254 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Simple flags parsing module, inspired by @optparse-applicative@.+--+-- Sample usage (note the default log level and optional context):+--+-- @+-- module Main where+--+-- 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+--   , logLevel :: Int+--   , context :: Maybe Text+--   } deriving Show+--+-- optionsParser :: FlagParser Options+-- optionsParser = Options \<$\> textFlag "root" "path to the root"+--                         \<*\> (numericFlag decimal "log_level" "" \<|\> pure 0)+--                         \<*\> (optional $ textFlag "context" "")+--+-- main :: IO ()+-- main = do+--   args <- getArgs+--   print $ parseFlags optionsParser args+-- @++-- TODO: Add @--help@ support.++module Flags.Applicative+  ( Name, FlagParser, FlagError(..), ParserError(..)+  , parseFlags+  -- * Nullary flags+  , boolFlag+  -- * Unary flags+  , unaryFlag, textFlag, numericFlag+  ) where++import Control.Applicative ((<|>), Alternative, empty, optional)+import Control.Monad (when)+import Control.Monad.Except (Except, catchError, runExcept, throwError)+import Control.Monad.RWS.Strict (RWST, runRWST)+import Control.Monad.Reader (asks)+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.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import Data.Maybe (isJust)+import Data.Set (Set)+import Data.Text (Text)+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++-- | 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.+type Name = Text++data Arity = Nullary | Unary deriving Eq+data Flag = Flag Arity Text++-- The errors which can happen during flag parsing.+data ValueError+  = MissingValue Name+  | InvalidValue Name Text String++type Action a = RWST+  (Map Name Text) -- Flag values (or empty for nullary flags).+  (Set Name) -- Read flags.+  (Set Name) -- Used flags.+  (Except ValueError) -- Eventual parsing error.+  a++-- | 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).+  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@)+-- 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)+  | Invalid ParserError+  deriving Functor++-- Returns the combined map of flags if there are no duplicates, otherwise the name of one of the+-- duplicate flags.+mergeFlags :: Map Name Flag -> Map Name Flag -> Either Name (Map Name Flag)+mergeFlags flags1 flags2 = case Map.minViewWithKey $ flags1 `Map.intersection` flags2 of+  Just ((name, _), _) -> Left name+  Nothing -> Right $ flags1 `Map.union` flags2++instance Applicative FlagParser where+  pure res = Actionable (pure res) Map.empty++  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 (action1 <*> action2) flags++instance Alternative FlagParser where+  empty = Invalid Empty++  Invalid Empty <|> parser = parser+  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++-- | The possible parsing errors.+data FlagError+  -- | At least one unary flag was specified multiple times with different values.+  = 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+  -- 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+  -- | 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)+  -- | An unknown flag was set.+  | 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++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+  action = do+    present <- asks (Map.member name)+    when present $ useFlag name+    pure present+  flags = Map.singleton name (Flag Nullary desc)++-- | 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+  action = do+    useFlag name+    asks (Map.lookup name) >>= \case+      Nothing -> throwError $ MissingValue name+      Just val -> case convert val of+        Left err -> throwError $ InvalidValue name val err+        Right res -> pure res+  flags = Map.singleton name (Flag Unary desc)++-- | Returns a flag with 'Text' values.+textFlag :: Name -> Text -> 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"

+ test/Spec.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative ((<|>))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Text.Read (decimal)+import Flags.Applicative+import Test.Hspec+import Test.Hspec.QuickCheck++main :: IO ()+main = hspec $ do+  describe "parse" $ do+    it "should parse a single flag" $ do+      let+        parser = textFlag "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" ""+        res = parseFlags parser []+      res `shouldBe` Left (InvalidParser $ DuplicateFlag "foo")+    it "should fail on unknown flags" $ do+      let+        parser = textFlag "foo" ""+        res = parseFlags parser ["hi", "--bar"]+      res `shouldBe` Left (UnknownFlag "bar")+    it "should detect unexpected flags" $ do+      let+        parser = boolFlag "bar" "" <|> boolFlag "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"]+      res `shouldBe` Right (Right "yes", ["no"])+    it "should branch correctly with nullary flags" $ do+      let+        parser = (True <$ boolFlag "true" "") <|> (False <$ boolFlag "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" ""+        res = parseFlags parser ["--foo=1", "--foo=2"]+      res `shouldBe` Left (InconsistentFlagValues "foo")+    it "should support the same flag value multiple times" $ do+      let+        parser = numericFlag decimal "foo" "" :: FlagParser Int+        res = parseFlags parser ["--foo=1", "--foo=1"]+      res `shouldBe` Right (1, [])