getopt-generics 0.12 → 0.13

raw patch · 29 files changed

+736/−662 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• docs/RecordType.hs +7/−9
• docs/SimpleRecord.hs +0/−20
• docs/SimpleRecord.shell-protocol +0/−16
• getopt-generics.cabal +12/−12
• src/System/Console/GetOpt/Generics.hs +0/−123
• src/System/Console/GetOpt/Generics/Modifier.hs +0/−137
• src/System/Console/GetOpt/Generics/Modifier/Types.hs +0/−20
• src/WithCli.hs +11/−12
• src/WithCli/Flag.hs +16/−2
• src/WithCli/HasArguments.hs +24/−13
• src/WithCli/Modifier.hs +137/−0
• src/WithCli/Modifier/Types.hs +20/−0
• src/WithCli/Parser.hs +19/−10
• src/WithCli/Pure.hs +40/−0
• src/WithCli/Pure/Internal.hs +35/−0
• src/WithCli/Result.hs +33/−14
• test/DocsSpec.hs +2/−4
• test/ModifiersSpec.hs +4/−4
• test/ModifiersSpec/RenameOptionsSpec.hs +6/−2
• test/ModifiersSpec/UseForPositionalArgumentsSpec.hs +9/−4
• test/System/Console/GetOpt/Generics/ModifierSpec.hs +0/−34
• test/System/Console/GetOpt/GenericsSpec.hs +0/−202
• test/Util.hs +15/−9
• test/WithCli/ModifierSpec.hs +34/−0
• test/WithCli/ParserSpec.hs +2/−2
• test/WithCli/Pure/RecordSpec.hs +206/−0
• test/WithCli/PureSpec.hs +33/−0
• test/WithCli/ResultSpec.hs +14/−9
• test/WithCliSpec.hs +57/−4

@@ -1,10 +1,9 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}  module RecordType where -import System.Console.GetOpt.Generics---- All you have to do is to define a type and derive an instance for Generic:+import WithCli  data Options   = Options {@@ -12,11 +11,10 @@     daemonize :: Bool,     config :: Maybe FilePath   }-  deriving (Show, Generic)---- Then you can use `getArguments` to create a command-line argument parser:+  deriving (Show, Generic, HasArguments)  main :: IO ()-main = do-  options <- getArguments-  print (options :: Options)+main = withCli run++run :: Options -> IO ()+run = print

@@ -1,20 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module SimpleRecord where--import WithCli--data Options-  = Options {-    port :: Int,-    daemonize :: Bool,-    config :: Maybe FilePath-  }-  deriving (Show, Generic, HasArguments)--main :: IO ()-main = withCli run--run :: Options -> IO ()-run = print

@@ -1,16 +0,0 @@-$ program --port 8080 --config some/path-Options {port = 8080, daemonize = False, config = Just "some/path"}-$ program  --port 8080 --daemonize-Options {port = 8080, daemonize = True, config = Nothing}-$ program --port foo-cannot parse as INTEGER: foo-# exit-code 1-$ program-missing option: --port=INTEGER-# exit-code 1-$ program --help-program [OPTIONS]-      --port=INTEGER-      --daemonize-      --config=STRING (optional)-  -h  --help                      show help and exit

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           getopt-generics-version:        0.12+version:        0.13 synopsis:       Create command line interfaces with ease description:    Create command line interfaces with ease category:       Console, System@@ -26,8 +26,6 @@     docs/RecordType.shell-protocol     docs/Simple.hs     docs/Simple.shell-protocol-    docs/SimpleRecord.hs-    docs/SimpleRecord.shell-protocol     docs/Test01.hs     docs/Test01.shell-protocol     docs/Test02.hs@@ -53,15 +51,16 @@     , tagged   exposed-modules:       WithCli-      System.Console.GetOpt.Generics+      WithCli.Pure   other-modules:-      System.Console.GetOpt.Generics.Modifier-      System.Console.GetOpt.Generics.Modifier.Types       WithCli.Argument       WithCli.Flag       WithCli.HasArguments+      WithCli.Modifier+      WithCli.Modifier.Types       WithCli.Normalize       WithCli.Parser+      WithCli.Pure.Internal       WithCli.Result   default-language: Haskell2010 @@ -85,35 +84,36 @@     , filepath     , safe   other-modules:-      System.Console.GetOpt.Generics-      System.Console.GetOpt.Generics.Modifier-      System.Console.GetOpt.Generics.Modifier.Types       WithCli       WithCli.Argument       WithCli.Flag       WithCli.HasArguments+      WithCli.Modifier+      WithCli.Modifier.Types       WithCli.Normalize       WithCli.Parser+      WithCli.Pure+      WithCli.Pure.Internal       WithCli.Result       DocsSpec       ModifiersSpec       ModifiersSpec.RenameOptionsSpec       ModifiersSpec.UseForPositionalArgumentsSpec       ShellProtocol-      System.Console.GetOpt.Generics.ModifierSpec-      System.Console.GetOpt.GenericsSpec       Util       WithCli.ArgumentSpec       WithCli.HasArgumentsSpec+      WithCli.ModifierSpec       WithCli.NormalizeSpec       WithCli.ParserSpec+      WithCli.Pure.RecordSpec+      WithCli.PureSpec       WithCli.ResultSpec       WithCliSpec       CustomOption       CustomOptionRecord       RecordType       Simple-      SimpleRecord       Test01       Test02       Test03

@@ -1,123 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module System.Console.GetOpt.Generics (-  -- * Simple IO API-  withCli,-  WithCli(),-  HasArguments,-  WithCli.Argument(argumentType, parseArgument),-  -- * Customizing the CLI-  withCliModified,-  Modifier(..),-  -- * IO API-  getArguments,-  modifiedGetArguments,-  -- * Pure API-  parseArguments,-  Result(..),-  -- * Re-exports-  GHC.Generic,-  GDatatypeInfo,-  GCode,-  All2,- ) where--import qualified GHC.Generics as GHC-import           Generics.SOP-import           Generics.SOP.GGP-import           System.Environment--import           System.Console.GetOpt.Generics.Modifier-import           WithCli-import           WithCli.HasArguments-import           WithCli.Parser-import           WithCli.Result---- | Parses command line arguments (gotten from 'withArgs') and returns the---   parsed value. This function should be enough for simple use-cases.------   Throws the same exceptions as 'withCli'.------ Here's an example:---- ### Start "docs/RecordType.hs" "" Haddock ###---- |--- >  {-# LANGUAGE DeriveGeneric #-}--- >--- >  module RecordType where--- >--- >  import System.Console.GetOpt.Generics--- >--- >  -- All you have to do is to define a type and derive an instance for Generic:--- >--- >  data Options--- >    = Options {--- >      port :: Int,--- >      daemonize :: Bool,--- >      config :: Maybe FilePath--- >    }--- >    deriving (Show, Generic)--- >--- >  -- Then you can use `getArguments` to create a command-line argument parser:--- >--- >  main :: IO ()--- >  main = do--- >    options <- getArguments--- >    print (options :: Options)---- ### End ###---- | And this is how the above program behaves:---- ### Start "docs/RecordType.shell-protocol" "" Haddock ###---- |--- >  $ program --port 8080 --config some/path--- >  Options {port = 8080, daemonize = False, config = Just "some/path"}--- >  $ program  --port 8080 --daemonize--- >  Options {port = 8080, daemonize = True, config = Nothing}--- >  $ program --port foo--- >  cannot parse as INTEGER: foo--- >  # exit-code 1--- >  $ program--- >  missing option: --port=INTEGER--- >  # exit-code 1--- >  $ program --help--- >  program [OPTIONS]--- >        --port=INTEGER--- >        --daemonize--- >        --config=STRING (optional)--- >    -h  --help                      show help and exit---- ### End ###--getArguments :: forall a . (GHC.Generic a, GTo a, GDatatypeInfo a, All2 HasArguments (GCode a)) =>-  IO a-getArguments = modifiedGetArguments []---- | Like 'getArguments` but allows you to pass in 'Modifier's.-modifiedGetArguments :: forall a . (GHC.Generic a, GTo a, GDatatypeInfo a, All2 HasArguments (GCode a)) =>-  [Modifier] -> IO a-modifiedGetArguments modifiers = do-  args <- getArgs-  progName <- getProgName-  handleResult $ parseArguments progName modifiers args---- | Pure variant of 'modifiedGetArguments'.------   Does not throw any exceptions.-parseArguments :: forall a . (GHC.Generic a, GTo a, GDatatypeInfo a, All2 HasArguments (GCode a)) =>-     String -- ^ Name of the program (e.g. from 'getProgName').-  -> [Modifier] -- ^ List of 'Modifier's to manually tweak the command line interface.-  -> [String] -- ^ List of command line arguments to parse (e.g. from 'getArgs').-  -> Result a-parseArguments progName mods args = do-  modifiers <- mkModifiers mods-  parser <- genericParser modifiers-  runParser progName modifiers-    (normalizeParser (applyModifiers modifiers parser)) args

@@ -1,137 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs            #-}-{-# LANGUAGE LambdaCase       #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE ViewPatterns     #-}--module System.Console.GetOpt.Generics.Modifier (-  Modifier(..),-  Modifiers,-  mkModifiers,-  isPositionalArgumentsField,-  getPositionalArgumentType,-  getVersion,--  applyModifiers,-  applyModifiersLong,--  -- exported for testing-  insertWith,- ) where--import           Prelude ()-import           Prelude.Compat--import           Control.Arrow-import           Control.Monad-import           Data.Char-import           Data.List (foldl')-import           Data.Maybe-import           System.Console.GetOpt--import           System.Console.GetOpt.Generics.Modifier.Types-import           WithCli.Parser-import           WithCli.Normalize-import           WithCli.Result---- | 'Modifier's can be used to customize the command line parser.-data Modifier-  = AddShortOption String Char-    -- ^ @AddShortOption fieldName c@ adds the 'Char' @c@ as a short option for-    --   the field addressed by @fieldName@.-  | RenameOption String String-    -- ^ @RenameOption fieldName customName@ renames the option generated-    --   through the @fieldName@ by @customName@.-  | RenameOptions (String -> Maybe String)-    -- ^ @RenameOptions f@ renames all options with the given functions. In case-    --   the function returns @Nothing@ the original field name is used.-    ---    --   Can be used together with 'Data.List.stripPrefix'.-  | UseForPositionalArguments String String-    -- ^ @UseForPositionalArguments fieldName argumentType@ fills the field-    --   addressed by @fieldName@ with the positional arguments (i.e. arguments-    --   that don't correspond to a flag). The field has to have type-    --   @['String']@.-    ---    --   @argumentType@ is used as the type of the positional arguments in the-    --   help output.-  | AddOptionHelp String String-    -- ^ @AddOptionHelp fieldName helpText@ adds a help text for the option-    --   @fieldName@.-  | AddVersionFlag String-    -- ^ @AddVersionFlag version@ adds a @--version@ flag.--mkModifiers :: [Modifier] -> Result Modifiers-mkModifiers = foldM inner empty-  where-    empty :: Modifiers-    empty = Modifiers [] id Nothing [] Nothing--    inner :: Modifiers -> Modifier -> Result Modifiers-    inner (Modifiers shorts renaming args help version) modifier = case modifier of-      (AddShortOption option short) ->-        return $ Modifiers (insertWith (++) option [short] shorts) renaming args help version-      (RenameOption from to) ->-        let newRenaming :: String -> String-            newRenaming option = if from `matches` option-              then to-              else option-        in return $ Modifiers shorts (renaming . newRenaming) args help version-      (RenameOptions newRenaming) ->-        return $ Modifiers shorts (renaming `combineRenamings` newRenaming) args help version-      (UseForPositionalArguments option typ) -> case args of-        Nothing -> return $ Modifiers shorts renaming (Just (option, map toUpper typ)) help version-        Just _ -> Errors ["UseForPositionalArguments can only be used once"]-      (AddOptionHelp option helpText) ->-        return $ Modifiers shorts renaming args (insert option helpText help) version-      (AddVersionFlag v) ->-        return $ Modifiers shorts renaming args help (Just v)--    combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a)-    combineRenamings old new x = old (fromMaybe x (new x))---- * list utils to replace Data.Map--insertWith :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]-insertWith _ key value [] = [(key, value)]-insertWith combine key value ((a, b) : r) =-  if a == key-    then (key, b `combine` value) : r-    else (a, b) : insertWith combine key value r--insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]-insert key value [] = [(key, value)]-insert key value ((a, b) : r) =-  if a == key-    then (key, value) : r-    else (a, b) : insert key value r---- * transforming Parsers--applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a-applyModifiers modifiers =-  addShortOptions >>>-  renameOptions-  where-    addShortOptions = modParserOptions $ map $-      \ option ->-        case filter (\ (needle, _) -> needle `elem` longs option) (shortOptions modifiers) of-          [] -> option-          (concat . map snd -> newShorts) ->-            foldl' (flip addShort) option newShorts-    renameOptions =-      modParserOptions $ map $ modLongs $ renaming modifiers--applyModifiersLong :: Modifiers -> String -> String-applyModifiersLong modifiers long = (renaming modifiers) long--longs :: OptDescr a -> [String]-longs (Option _ ls _ _) = ls--addShort :: Char -> OptDescr a -> OptDescr a-addShort short (Option shorts longs argDescrs help) =-  Option (shorts ++ [short]) longs argDescrs help--modLongs :: (String -> String) -> OptDescr a -> OptDescr a-modLongs f (Option shorts longs descrs help) =-  Option shorts (map f longs) descrs help

@@ -1,20 +0,0 @@--module System.Console.GetOpt.Generics.Modifier.Types where--data Modifiers = Modifiers {-  shortOptions :: [(String, [Char])],-  renaming :: String -> String,-  positionalArgumentsField :: Maybe (String, String),-  _helpTexts :: [(String, String)],-  version :: Maybe String- }--getVersion :: Modifiers -> Maybe String-getVersion modifiers = version modifiers--isPositionalArgumentsField :: Modifiers -> String -> Bool-isPositionalArgumentsField modifiers field =-  maybe False ((field ==) . fst) (positionalArgumentsField modifiers)--getPositionalArgumentType :: Modifiers -> Maybe String-getPositionalArgumentType = fmap snd . positionalArgumentsField

@@ -19,17 +19,16 @@   Proxy(..),   ) where --- todo: add pure api with withCli- import           Data.Proxy import           Data.Typeable import qualified GHC.Generics as GHC import           System.Environment -import           System.Console.GetOpt.Generics.Modifier import           WithCli.Argument import           WithCli.HasArguments+import           WithCli.Modifier import           WithCli.Parser+import qualified WithCli.Pure.Internal import           WithCli.Result  -- | 'withCli' converts an IO operation into a program with a proper CLI.@@ -93,22 +92,22 @@ withCliModified mods main = do   args <- getArgs   modifiers <- handleResult (mkModifiers mods)-  _run modifiers (return $ emptyParser ()) (\ () -> main) args+  run modifiers (return $ emptyParser ()) (\ () -> main) args  -- | Everything that can be used as a @main@ function with 'withCli' needs to --   have an instance of 'WithCli'. You shouldn't need to implement your own --   instances. class WithCli main where-  _run :: Modifiers -> Result (Parser Unnormalized a) -> (a -> main) -> [String] -> IO ()+  run :: Modifiers -> Result (Parser Unnormalized a) -> (a -> main) -> [String] -> IO ()  instance WithCli (IO ()) where-  _run modifiers mkParser mkMain args = do+  run modifiers mkParser mkMain args = do     progName <- getProgName-    parser <- handleResult mkParser-    a <- handleResult $ runParser progName modifiers-      (normalizeParser (applyModifiers modifiers parser)) args-    mkMain a+    let result = WithCli.Pure.Internal.run+          progName modifiers mkParser mkMain args+    action <- handleResult result+    action  instance (HasArguments a, WithCli rest) => WithCli (a -> rest) where-  _run modifiers fa mkMain args =-    _run modifiers (combine fa (argumentsParser modifiers Nothing)) (\ (a, r) -> mkMain a r) args+  run modifiers fa mkMain args =+    run modifiers (combine fa (argumentsParser modifiers Nothing)) (\ (a, r) -> mkMain a r) args

@@ -1,10 +1,12 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ViewPatterns #-}  module WithCli.Flag where  import           Prelude () import           Prelude.Compat +import           Data.Maybe import           Data.Monoid import           System.Console.GetOpt @@ -34,12 +36,24 @@ versionOption version =   Option ['v'] ["version"] (NoArg (Version version)) "show version and exit" -usage :: String -> [String] -> [OptDescr ()] -> String+usage :: String -> [(Bool, String)] -> [OptDescr ()] -> String usage progName fields options = usageInfo header options   where     header :: String     header = unwords $       progName :       "[OPTIONS]" :-       fields +++      fromMaybe [] (formatFields fields) ++       []++    formatFields :: [(Bool, String)] -> Maybe [String]+    formatFields [] = Nothing+    formatFields fields = Just $+      let (map snd -> nonOptional, map snd -> optional) =+            span (not . fst) fields+      in nonOptional ++ [formatOptional optional]++    formatOptional :: [String] -> String+    formatOptional [] = ""+    formatOptional [a] = "[" ++ a ++ "]"+    formatOptional (a : r) = "[" ++ a ++ " " ++ formatOptional r ++ "]"

@@ -36,8 +36,8 @@ import           System.Console.GetOpt import           Text.Read -import           System.Console.GetOpt.Generics.Modifier import           WithCli.Argument+import           WithCli.Modifier import           WithCli.Normalize import           WithCli.Parser import           WithCli.Result@@ -48,7 +48,7 @@   Nothing -> parseError (argumentType (Proxy :: Proxy a)) mMsg s  parseError :: String -> Maybe String -> String -> Result a-parseError typ mMsg s = Errors $ pure $+parseError typ mMsg s = Errors $   "cannot parse as " ++ typ ++   maybe "" (\ msg -> " (" ++ msg ++ ")") mMsg ++   ": " ++ s@@ -59,7 +59,7 @@ --   'HasArguments' also allows to conjure up instances for record types --   to create more complex command line interfaces. Here's an example: --- ### Start "docs/SimpleRecord.hs" "module SimpleRecord where\n\n" Haddock ###+-- ### Start "docs/RecordType.hs" "module RecordType where\n\n" Haddock ###  -- | -- >  {-# LANGUAGE DeriveAnyClass #-}@@ -85,7 +85,7 @@  -- | In a shell this program behaves like this: --- ### Start "docs/SimpleRecord.shell-protocol" "" Haddock ###+-- ### Start "docs/RecordType.shell-protocol" "" Haddock ###  -- | -- >  $ program --port 8080 --config some/path@@ -139,7 +139,7 @@ wrapForPositionalArguments :: String -> (Modifiers -> Maybe String -> Result a) -> (Modifiers -> Maybe String -> Result a) wrapForPositionalArguments typ wrapped modifiers (Just field) =   if isPositionalArgumentsField modifiers field-    then Errors ["UseForPositionalArguments can only be used for fields of type [String] not " ++ typ]+    then Errors ("UseForPositionalArguments can only be used for fields of type [String] not " ++ typ)     else wrapped modifiers (Just field) wrapForPositionalArguments _ wrapped modifiers Nothing = wrapped modifiers Nothing @@ -172,10 +172,10 @@       parserDefault = Nothing,       parserOptions = [],       parserNonOptions =-        [NonOptionsParser typ (\ (s : r) -> fmap ((, r) . const . Just) $ parseArgumentResult Nothing s)],+        [NonOptionsParser typ False (\ (s : r) -> fmap ((, r) . const . Just) $ parseArgumentResult Nothing s)],       parserConvert = \ case         Just a -> return a-        Nothing -> Errors $ pure $+        Nothing -> Errors $           "missing argument of type " ++ typ     } @@ -189,7 +189,7 @@       parserNonOptions = [],       parserConvert = \ case         Right a -> return a-        Left () -> Errors $ pure $+        Left () -> Errors $           "missing option: --" ++ normalize (applyModifiersLong modifiers long) ++ "=" ++ typ     } @@ -214,7 +214,7 @@ positionalArgumentsParser = Parser {   parserDefault = [],   parserOptions = [],-  parserNonOptions = [NonOptionsParser (argumentType (Proxy :: Proxy a)) parse],+  parserNonOptions = [NonOptionsParser (argumentType (Proxy :: Proxy a)) True parse],   parserConvert = return }   where@@ -229,7 +229,18 @@ maybeParser :: forall a . Argument a =>   Maybe String -> Result (Parser Unnormalized (Maybe a)) maybeParser mLong = case mLong of-  Nothing -> Errors ["cannot use Maybes for positional arguments"]+  Nothing -> return $ Parser {+    parserDefault = Nothing,+    parserOptions = [],+    parserNonOptions =+      let parse :: [String] -> Result (Maybe a -> Maybe a, [String])+          parse (a : r) = do+            v <- parseArgumentResult (Just "optional") a+            return (const (Just v), r)+          parse [] = return (id, [])+      in [NonOptionsParser (argumentType (Proxy :: Proxy a)) True parse],+    parserConvert = return+  }   Just long -> return $ Parser {     parserDefault = Nothing,     parserOptions = pure $@@ -248,10 +259,10 @@     parserDefault = Nothing,     parserOptions = [],     parserNonOptions = pure $-      (NonOptionsParser "BOOL" (\ (s : r) -> (, r) <$> maybe (parseError "BOOL" Nothing s) (return . const . Just) (parseBool s))),+      (NonOptionsParser "BOOL" False (\ (s : r) -> (, r) <$> maybe (parseError "BOOL" Nothing s) (return . const . Just) (parseBool s))),     parserConvert = \ case       Just x -> return x-      Nothing -> Errors $ pure $+      Nothing -> Errors $         "missing argument of type BOOL"   }   Just long -> Parser {@@ -296,7 +307,7 @@   Newtype _ typeName (Constructor _) ->     err typeName "constructors without field labels"   where-    err typeName message = Errors $ pure $+    err typeName message = Errors $       "getopt-generics doesn't support " ++ message ++       " (" ++ typeName ++ ")." 

@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE LambdaCase       #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE ViewPatterns     #-}++module WithCli.Modifier (+  Modifier(..),+  Modifiers,+  mkModifiers,+  isPositionalArgumentsField,+  getPositionalArgumentType,+  getVersion,++  applyModifiers,+  applyModifiersLong,++  -- exported for testing+  insertWith,+ ) where++import           Prelude ()+import           Prelude.Compat++import           Control.Arrow+import           Control.Monad+import           Data.Char+import           Data.List (foldl')+import           Data.Maybe+import           System.Console.GetOpt++import           WithCli.Modifier.Types+import           WithCli.Normalize+import           WithCli.Parser+import           WithCli.Result++-- | 'Modifier's can be used to customize the command line parser.+data Modifier+  = AddShortOption String Char+    -- ^ @AddShortOption fieldName c@ adds the 'Char' @c@ as a short option for+    --   the field addressed by @fieldName@.+  | RenameOption String String+    -- ^ @RenameOption fieldName customName@ renames the option generated+    --   through the @fieldName@ by @customName@.+  | RenameOptions (String -> Maybe String)+    -- ^ @RenameOptions f@ renames all options with the given functions. In case+    --   the function returns @Nothing@ the original field name is used.+    --+    --   Can be used together with 'Data.List.stripPrefix'.+  | UseForPositionalArguments String String+    -- ^ @UseForPositionalArguments fieldName argumentType@ fills the field+    --   addressed by @fieldName@ with the positional arguments (i.e. arguments+    --   that don't correspond to a flag). The field has to have type+    --   @['String']@.+    --+    --   @argumentType@ is used as the type of the positional arguments in the+    --   help output.+  | AddOptionHelp String String+    -- ^ @AddOptionHelp fieldName helpText@ adds a help text for the option+    --   @fieldName@.+  | AddVersionFlag String+    -- ^ @AddVersionFlag version@ adds a @--version@ flag.++mkModifiers :: [Modifier] -> Result Modifiers+mkModifiers = foldM inner empty+  where+    empty :: Modifiers+    empty = Modifiers [] id Nothing [] Nothing++    inner :: Modifiers -> Modifier -> Result Modifiers+    inner (Modifiers shorts renaming args help version) modifier = case modifier of+      (AddShortOption option short) ->+        return $ Modifiers (insertWith (++) option [short] shorts) renaming args help version+      (RenameOption from to) ->+        let newRenaming :: String -> String+            newRenaming option = if from `matches` option+              then to+              else option+        in return $ Modifiers shorts (renaming . newRenaming) args help version+      (RenameOptions newRenaming) ->+        return $ Modifiers shorts (renaming `combineRenamings` newRenaming) args help version+      (UseForPositionalArguments option typ) -> case args of+        Nothing -> return $ Modifiers shorts renaming (Just (option, map toUpper typ)) help version+        Just _ -> Errors "UseForPositionalArguments can only be used once"+      (AddOptionHelp option helpText) ->+        return $ Modifiers shorts renaming args (insert option helpText help) version+      (AddVersionFlag v) ->+        return $ Modifiers shorts renaming args help (Just v)++    combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a)+    combineRenamings old new x = old (fromMaybe x (new x))++-- * list utils to replace Data.Map++insertWith :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]+insertWith _ key value [] = [(key, value)]+insertWith combine key value ((a, b) : r) =+  if a == key+    then (key, b `combine` value) : r+    else (a, b) : insertWith combine key value r++insert :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+insert key value [] = [(key, value)]+insert key value ((a, b) : r) =+  if a == key+    then (key, value) : r+    else (a, b) : insert key value r++-- * transforming Parsers++applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a+applyModifiers modifiers =+  addShortOptions >>>+  renameOptions+  where+    addShortOptions = modParserOptions $ map $+      \ option ->+        case filter (\ (needle, _) -> needle `elem` longs option) (shortOptions modifiers) of+          [] -> option+          (concat . map snd -> newShorts) ->+            foldl' (flip addShort) option newShorts+    renameOptions =+      modParserOptions $ map $ modLongs $ renaming modifiers++applyModifiersLong :: Modifiers -> String -> String+applyModifiersLong modifiers long = (renaming modifiers) long++longs :: OptDescr a -> [String]+longs (Option _ ls _ _) = ls++addShort :: Char -> OptDescr a -> OptDescr a+addShort short (Option shorts longs argDescrs help) =+  Option (shorts ++ [short]) longs argDescrs help++modLongs :: (String -> String) -> OptDescr a -> OptDescr a+modLongs f (Option shorts longs descrs help) =+  Option shorts (map f longs) descrs help

@@ -0,0 +1,20 @@++module WithCli.Modifier.Types where++data Modifiers = Modifiers {+  shortOptions :: [(String, [Char])],+  renaming :: String -> String,+  positionalArgumentsField :: Maybe (String, String),+  _helpTexts :: [(String, String)],+  version :: Maybe String+ }++getVersion :: Modifiers -> Maybe String+getVersion modifiers = version modifiers++isPositionalArgumentsField :: Modifiers -> String -> Bool+isPositionalArgumentsField modifiers field =+  maybe False ((field ==) . fst) (positionalArgumentsField modifiers)++getPositionalArgumentType :: Modifiers -> Maybe String+getPositionalArgumentType = fmap snd . positionalArgumentsField

@@ -16,15 +16,17 @@ import           Control.Monad import           System.Console.GetOpt as Base -import           System.Console.GetOpt.Generics.Modifier.Types import           WithCli.Flag+import           WithCli.Modifier.Types import           WithCli.Normalize import           WithCli.Result  data NonOptionsParser uninitialized =   NonOptionsParser {     nonOptionsType :: String,-    nonOptionsParser :: [String] -> Result (uninitialized -> uninitialized, [String])+    nonOptionsOptional :: Bool,+    nonOptionsParser ::+      [String] -> Result (uninitialized -> uninitialized, [String])   }  combineNonOptionsParser :: [NonOptionsParser u] -> [NonOptionsParser v]@@ -34,8 +36,8 @@   map (modMod second) b   where     modMod :: ((a -> a) -> (b -> b)) -> NonOptionsParser a -> NonOptionsParser b-    modMod f (NonOptionsParser field parser) =-      NonOptionsParser field (fmap (fmap (first f)) parser)+    modMod f (NonOptionsParser field optional parser) =+      NonOptionsParser field optional (fmap (fmap (first f)) parser)  data Parser phase a where   Parser :: {@@ -104,22 +106,23 @@ fillInNonOptions [] [] u =   return u fillInNonOptions [] nonOptions _ =-  Errors (map ("unknown argument: " ++) nonOptions)+  Errors $ unlines (map ("unknown argument: " ++) nonOptions) fillInNonOptions _ [] u = return u  runParser :: String -> Modifiers -> Parser Normalized a -> [String] -> Result a-runParser progName modifiers Parser{..} args = do+runParser progName modifiers Parser{..} args =+  checkNonOptionParsers parserNonOptions |>   let versionOptions = maybe []         (\ v -> pure $ versionOption (progName ++ " version " ++ v))         (getVersion modifiers)       options = map (fmap NoHelp) parserOptions ++ [helpOption] ++ versionOptions       (flags, nonOptions, errs) =         Base.getOpt Base.Permute options args-  case foldFlags flags of+  in case foldFlags flags of     Help -> OutputAndExit $       let fields = case getPositionalArgumentType modifiers of-            Nothing -> map nonOptionsType parserNonOptions-            Just typ -> ["[" ++ typ ++ "]"]+            Nothing -> map (\ p -> (nonOptionsOptional p, nonOptionsType p)) parserNonOptions+            Just typ -> [(True, typ)]       in usage progName fields (map void options)     Version msg -> OutputAndExit msg     NoHelp innerFlags ->@@ -131,4 +134,10 @@     reportErrors :: [String] -> Result ()     reportErrors = \ case       [] -> return ()-      errs -> Errors errs+      errs -> Errors $ unlines errs++    checkNonOptionParsers :: [NonOptionsParser a] -> Result ()+    checkNonOptionParsers parsers =+      case dropWhile nonOptionsOptional $ dropWhile (not . nonOptionsOptional) parsers of+        [] -> return ()+        (_ : _) -> Errors "cannot use Maybes for optional arguments before any non-optional arguments"

@@ -0,0 +1,40 @@++module WithCli.Pure (+  withCliPure,+  WithCliPure(),+  Result(..),+  handleResult,+  HasArguments(argumentsParser),+  atomicArgumentsParser,+  Argument(argumentType, parseArgument),+  -- * Modifiers+  Modifier(..),+  -- * Useful Re-exports+  GHC.Generic,+  Typeable,+  Proxy(..),+) where++import           Data.Proxy+import           Data.Typeable+import           GHC.Generics as GHC++import           WithCli.Argument+import           WithCli.HasArguments+import           WithCli.Modifier+import           WithCli.Parser+import           WithCli.Pure.Internal+import           WithCli.Result++-- | Pure variant of 'WithCli.withCliModified'.+withCliPure :: WithCliPure function a => String -> [Modifier] -> [String]+  -> function+    -- ^ The @function@ parameter can be a+    -- function with arbitrary many parameters as long as they have an instance+    -- for 'HasArguments'. You can choose the return type of @function@ freely,+    -- 'withCliPure' will return it wrapped in 'Result' to account for parse+    -- errors, etc. (see 'Result').+  -> Result a+withCliPure progName modifiers args function = sanitize $ do+  modifiers <- mkModifiers modifiers+  run progName modifiers (return $ emptyParser ()) (\ () -> function) args

@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module WithCli.Pure.Internal where++import           WithCli.HasArguments+import           WithCli.Modifier+import           WithCli.Parser+import           WithCli.Result++class WithCliPure function output where+  run :: String -> Modifiers -> Result (Parser Unnormalized input)+    -> (input -> function) -> [String] -> Result output++instance WithCliPure output output where+  run :: String -> Modifiers -> Result (Parser Unnormalized input) -> (input -> output)+    -> [String] -> Result output+  run progName modifiers mkParser function args = do+    mkParser >>= \ parser -> do+      input <- runParser progName modifiers+        (normalizeParser (applyModifiers modifiers parser))+        args+      return $ function input++instance (HasArguments input, WithCliPure function output) =>+  WithCliPure (input -> function) output where++  run :: String -> Modifiers -> Result (Parser Unnormalized otherInput)+    -> (otherInput -> (input -> function)) -> [String] -> Result output+  run progName modifiers mkParser function args = do+    run progName modifiers+      (combine mkParser (argumentsParser modifiers Nothing))+      (\ (otherInput, input) -> function otherInput input)+      args

@@ -1,10 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-}  module WithCli.Result (   Result(..),+  (|>),   handleResult,+  sanitizeMessage,   sanitize,  ) where @@ -12,18 +15,16 @@ import           Prelude.Compat  import           Control.Arrow-import           Data.List.Compat import           System.Exit import           System.IO --- | Type to wrap results from the pure parsing functions.+-- | Type to wrap results from 'WithCli.Pure.withCliPure'. data Result a   = Success a     -- ^ The CLI was used correctly and a value of type @a@ was     --   successfully constructed.-  | Errors [String]-    -- ^ The CLI was used incorrectly. The 'Result' contains a list of error-    --   messages.+  | Errors String+    -- ^ The CLI was used incorrectly. The 'Result' contains error messages.     --     --   It can also happen that the data type you're trying to use isn't     --   supported. See the@@ -38,10 +39,13 @@   OutputAndExit message <*> _ = OutputAndExit message   _ <*> OutputAndExit message = OutputAndExit message   Success f <*> Success x = Success (f x)-  Errors a <*> Errors b = Errors (a ++ b)-  Errors errs <*> Success _ = Errors errs-  Success _ <*> Errors errs = Errors errs+  Errors a <*> Errors b = Errors (a ++ "\n" ++ b)+  Errors err <*> Success _ = Errors err+  Success _ <*> Errors err = Errors err +(|>) :: Result a -> Result b -> Result b+a |> b = a >>= const b+ instance Monad Result where   return = pure   Success a >>= b = b a@@ -50,18 +54,33 @@    (>>) = (*>) +-- | Handles an input of type @'Result' a@:+--+-- - On @'Success' a@ it returns the value @a@.+-- - On @'OutputAndExit' message@ it writes the message to 'stdout' and throws+--   'ExitSuccess'.+-- - On @'Errors' errs@ it writes the error messages to 'stderr' and throws+--   @'ExitFailure' 1@.+--+-- This is used by 'WithCli.withCli' to handle parse results. handleResult :: Result a -> IO a-handleResult result = case result of+handleResult result = case sanitize result of   Success a -> return a   OutputAndExit message -> do-    putStr $ sanitize message+    putStr message     exitWith ExitSuccess-  Errors errs -> do-    hPutStr stderr $ sanitize $ intercalate "\n" errs+  Errors err -> do+    hPutStr stderr err     exitWith $ ExitFailure 1 -sanitize :: String -> String-sanitize =+sanitize :: Result a -> Result a+sanitize = \ case+  Success a -> Success a+  OutputAndExit message -> OutputAndExit $ sanitizeMessage message+  Errors messages -> Errors $ sanitizeMessage messages++sanitizeMessage :: String -> String+sanitizeMessage =   lines >>>   map stripTrailingSpaces >>>   filter (not . null) >>>

@@ -13,13 +13,12 @@  import qualified Test01 import qualified CustomOption-import qualified RecordType import qualified Simple #if MIN_VERSION_base(4,8,0) import qualified Test02 import qualified Test03 import qualified Test04-import qualified SimpleRecord+import qualified RecordType import qualified CustomOptionRecord #endif @@ -27,13 +26,12 @@ examples =   (Test01.main, "Test01") :   (CustomOption.main, "CustomOption") :-  (RecordType.main, "RecordType") :   (Simple.main, "Simple") : #if MIN_VERSION_base(4,8,0)   (Test02.main, "Test02") :   (Test03.main, "Test03") :   (Test04.main, "Test04") :-  (SimpleRecord.main, "SimpleRecord") :+  (RecordType.main, "RecordType") :   (CustomOptionRecord.main, "CustomOptionRecord") : #endif   []

@@ -5,9 +5,9 @@ import           Data.List import           Test.Hspec -import           System.Console.GetOpt.Generics-import           System.Console.GetOpt.GenericsSpec import           Util+import           WithCli.Pure+import           WithCli.Pure.RecordSpec  spec :: Spec spec = do@@ -39,7 +39,7 @@        it "disregards the earlier renaming" $ do         let Errors errs = parse' "--foo foo"-        errs `shouldContain` ["unrecognized option `--foo'\n"]+        errs `shouldContain` "unrecognized option `--foo'\n"      it "contains renamed options in error messages" $ do       let Errors errs = modsParse@@ -57,7 +57,7 @@   describe "AddVersionFlag" $ do     it "implements --version" $ do       let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version" :: Result Foo-      output `shouldBe` "prog-name version 1.0.0"+      output `shouldBe` "prog-name version 1.0.0\n"      it "--help takes precedence over --version" $ do       let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version --help" :: Result Foo

@@ -6,8 +6,8 @@ import           Data.List import           Test.Hspec -import           System.Console.GetOpt.Generics import           Util+import           WithCli.Pure  data Foo   = Foo {@@ -16,6 +16,8 @@   }   deriving (Eq, Show, Generic) +instance HasArguments Foo+ data CommonPrefixes   = CP {     prefixFoo :: Int,@@ -24,6 +26,8 @@   }   deriving (Eq, Show, Generic) +instance HasArguments CommonPrefixes+ spec :: Spec spec = do   describe "RenameOptions" $ do@@ -40,7 +44,7 @@     it "missing options messages show renamed options" $ do       let Errors errs = modsParse             [RenameOptions (Just . map toLower)] "" :: Result CommonPrefixes-      errs `shouldSatisfy` ("missing option: --prefixfoo=INTEGER" `elem`)+      lines errs `shouldSatisfy` ("missing option: --prefixfoo=INTEGER" `elem`)      it "can be used to rename a single field" $ do       let rename f = case f of

@@ -7,8 +7,9 @@ import           System.Environment import           Test.Hspec -import           System.Console.GetOpt.Generics import           Util+import           WithCli+import           WithCli.Pure  data WithPositionalArguments   = WithPositionalArguments {@@ -17,6 +18,8 @@   }   deriving (Generic, Show, Eq) +instance HasArguments WithPositionalArguments+ data WithMultiplePositionalArguments   = WithMultiplePositionalArguments {     positionalArgumentsA :: [String],@@ -25,6 +28,8 @@   }   deriving (Generic, Show, Eq) +instance HasArguments WithMultiplePositionalArguments+ spec :: Spec spec = do   it "allows positionalArguments" $ do@@ -38,7 +43,7 @@       [UseForPositionalArguments "positionalArguments" "type"]       "--positional-arguments foo"         `shouldBe`-      (Errors ["unrecognized option `--positional-arguments'\n"]+      (Errors "unrecognized option `--positional-arguments'\n"         :: Result WithPositionalArguments)    it "complains about fields that don't have type [String]" $ do@@ -46,7 +51,7 @@       [UseForPositionalArguments "someFlag" "type"]       "doesn't matter"         `shouldBe`-      (Errors ["UseForPositionalArguments can only be used for fields of type [String] not Bool"]+      (Errors "UseForPositionalArguments can only be used for fields of type [String] not Bool\n"         :: Result WithPositionalArguments)    it "includes the type of positional arguments in the help output in upper-case" $ do@@ -61,7 +66,7 @@           UseForPositionalArguments "positionalArgumentsB" "bar" :           []     (modsParse modifiers [] :: Result WithMultiplePositionalArguments)-      `shouldBe` Errors ["UseForPositionalArguments can only be used once"]+      `shouldBe` Errors "UseForPositionalArguments can only be used once\n"    context "when used without selector" $ do     it "automatically uses positional arguments for [Int]" $ do

@@ -1,34 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module System.Console.GetOpt.Generics.ModifierSpec where--import           Test.Hspec--import           System.Console.GetOpt.Generics-import           System.Console.GetOpt.Generics.Modifier-import           Util--spec :: Spec-spec = do-  describe "insertWith" $ do-    it "combines existing values with the given function" $ do-      insertWith (++) (1 :: Integer) "bar" [(1, "foo")]-        `shouldBe` [(1, "foobar")]--  describe "getVersion" $ do-    it "returns the version" $ do-      let modifiers = unsafeModifiers [AddVersionFlag "1.0.0"]-      getVersion modifiers `shouldBe` Just "1.0.0"--data Foo-  = Foo {-    bar :: String-  }-  deriving (Generic)--data Overlap-  = Overlap {-    foo :: String,-    fooo :: String-  }-  deriving (Generic)

@@ -1,202 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}--module System.Console.GetOpt.GenericsSpec where--import           Prelude ()-import           Prelude.Compat--import           Control.Exception-import           Data.Foldable (forM_)-import           Data.List (isPrefixOf, isSuffixOf)-import           System.Environment-import           System.Exit-import           System.IO-import           System.IO.Silently-import           Test.Hspec--import           System.Console.GetOpt.Generics-import           Util-import           WithCli.Result--spec :: Spec-spec = do-  part1-  part2-  part3-  part4-  part5--data Foo-  = Foo {-    bar :: Maybe Int,-    baz :: String,-    bool :: Bool-  }-  deriving (Generic, Show, Eq)--data NotAllowed-  = NotAllowed1-  | NotAllowed2-  deriving (Generic, Show, Eq)--part1 :: Spec-part1 = do-  describe "getArguments" $ do-    it "parses command line arguments" $ do-      withArgs (words "--bar 4 --baz foo") $-        getArguments `shouldReturn` Foo (Just 4) "foo" False--  describe "parseArguments" $ do-    it "allows optional arguments" $ do-      parse "--baz foo" `shouldBe`-        Success (Foo Nothing "foo" False)--    it "allows boolean flags" $ do-      parse "--bool --baz foo" `shouldBe`-        Success (Foo Nothing "foo" True)--    it "allows to overwrite String options" $ do-      parse "--baz one --baz two"-        `shouldBe` Success (Foo Nothing "two" False)--    context "with invalid arguments" $ do-      it "prints out an error" $ do-        let Errors messages = parse "--no-such-option" :: Result Foo-        messages `shouldBe`-          ["unrecognized option `--no-such-option'\n",-           "missing option: --baz=STRING"]--      it "prints errors for missing options" $ do-        let Errors [message] = parse [] :: Result Foo-        message `shouldBe` "missing option: --baz=STRING"--      it "prints out an error for unparseable options" $ do-        let Errors [message] = parse "--bar foo --baz huhu" :: Result Foo-        message `shouldBe` "cannot parse as INTEGER (optional): foo"--      it "complains about unused positional arguments" $ do-        (parse "--baz foo unused" :: Result Foo)-          `shouldBe` Errors ["unknown argument: unused"]--      it "complains about invalid overwritten options" $ do-        let Errors [message] = parse "--bar foo --baz huhu --bar 12" :: Result Foo-        message `shouldBe` "cannot parse as INTEGER (optional): foo"--    context "--help" $ do-      it "implements --help" $ do-        let OutputAndExit output = parse "--help" :: Result Foo-        mapM_ (output `shouldContain`) $-          "--bar=INTEGER" : "optional" :-          "--baz=STRING" :-          "--bool" :-          []-        lines output `shouldSatisfy` (not . ("" `elem`))--      it "contains help message about --help" $ do-        let OutputAndExit output = parse "--help" :: Result Foo-        output `shouldContain` "show help and exit"--      it "does not contain trailing spaces" $ do-        output <--          hCapture_ [stdout] $-          handle (\ ExitSuccess -> return ()) $-          handleResult $ ((parse "--help" :: Result Foo) >> return ())-        forM_ (lines output) $ \ line -> do-          line `shouldSatisfy` (not . (" " `isSuffixOf`))--      it "complains when the options datatype is not allowed" $ do-        let Errors [message] = parse "--help" :: Result NotAllowed-        message `shouldSatisfy` ("getopt-generics doesn't support sum types" `isPrefixOf`)--      it "outputs a header including \"[OPTIONS]\"" $ do-        let OutputAndExit output = parse "--help" :: Result Foo-        output `shouldSatisfy` ("prog-name [OPTIONS]\n" `isPrefixOf`)--data ListOptions-  = ListOptions {-    multiple :: [Int]-  }-  deriving (Generic, Show, Eq)--part2 :: Spec-part2 = do-  describe "parseArguments" $ do-    it "allows to interpret multiple uses of the same option as lists" $ do-      parse "--multiple 23 --multiple 42"-        `shouldBe` Success (ListOptions [23, 42])--    it "complains about invalid list arguments" $ do-      let Errors errs =-            parse "--multiple foo --multiple 13" :: Result ListOptions-      errs `shouldBe` ["cannot parse as INTEGER (multiple possible): foo"]--data CamelCaseOptions-  = CamelCaseOptions {-    camelCase :: String-  }-  deriving (Generic, Show, Eq)--part3 :: Spec-part3 = do-  describe "parseArguments" $ do-    it "turns camelCase selectors to lowercase and seperates with a dash" $ do-      parse "--camel-case foo" `shouldBe` Success (CamelCaseOptions "foo")--    it "help does not contain camelCase flags" $ do-      let OutputAndExit output :: Result CamelCaseOptions-            = parse "--help"-      output `shouldNotContain` "camelCase"-      output `shouldContain` "camel-case"--    it "error messages don't contain camelCase flags" $ do-      let Errors errs :: Result CamelCaseOptions-            = parse "--bla"-      show errs `shouldNotContain` "camelCase"-      show errs `shouldContain` "camel-case"--data WithUnderscore-  = WithUnderscore {-    _withUnderscore :: String-  }-  deriving (Generic, Show, Eq)--part4 :: Spec-part4 = do-  describe "parseArguments" $ do-    it "ignores leading underscores in field names" $ do-      parse "--with-underscore foo"-        `shouldBe` Success (WithUnderscore "foo")--data WithoutSelectors-  = WithoutSelectors String Bool Int-  deriving (Eq, Show, Generic)--part5 :: Spec-part5 = do-  describe "parseArguments" $ do-    context "WithoutSelectors" $ do-      it "populates fields without selectors from positional arguments" $ do-        parse "foo true 23"-          `shouldBe` Success (WithoutSelectors "foo" True 23)--      it "has good help output for positional arguments" $ do-        let OutputAndExit output = parse "--help" :: Result WithoutSelectors-        output `shouldSatisfy` ("prog-name [OPTIONS] STRING BOOL INTEGER" `isPrefixOf`)--      it "has good error messages for missing positional arguments" $ do-        (parse "foo" :: Result WithoutSelectors)-          `shouldBe` Errors (-            "missing argument of type BOOL" :-            "missing argument of type INTEGER" :-            [])--      it "complains about additional positional arguments" $ do-        (parse "foo true 5 bar" :: Result WithoutSelectors)-          `shouldBe` Errors ["unknown argument: bar"]--      it "allows to use tuples" $ do-        (parse "42 bar" :: Result (Int, String))-          `shouldBe` Success (42, "bar")

@@ -1,22 +1,28 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  module Util where -import qualified GHC.Generics as GHC-import           Generics.SOP.GGP+import           Prelude ()+import           Prelude.Compat -import           System.Console.GetOpt.Generics-import           System.Console.GetOpt.Generics.Modifier+import           WithCli.Modifier+import           WithCli.Pure -parse :: (GHC.Generic a, GTo a, GDatatypeInfo a, All2 HasArguments (GCode a)) =>-  String -> Result a+parse :: (HasArguments a) => String -> Result a parse = modsParse [] -modsParse :: (GHC.Generic a, GTo a, GDatatypeInfo a, All2 HasArguments (GCode a)) =>-  [Modifier] -> String -> Result a-modsParse modifiers = parseArguments "prog-name" modifiers . words+data Wrapped a+  = Wrap {+    unwrap :: a+  }++modsParse :: forall a . (HasArguments a) => [Modifier] -> String -> Result a+modsParse modifiers args =+  unwrap <$>+  withCliPure "prog-name" modifiers (words args) (Wrap :: a -> Wrapped a)  unsafeModifiers :: [Modifier] -> Modifiers unsafeModifiers mods = case mkModifiers mods of

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}++module WithCli.ModifierSpec where++import           Test.Hspec++import           Util+import           WithCli+import           WithCli.Modifier++spec :: Spec+spec = do+  describe "insertWith" $ do+    it "combines existing values with the given function" $ do+      insertWith (++) (1 :: Integer) "bar" [(1, "foo")]+        `shouldBe` [(1, "foobar")]++  describe "getVersion" $ do+    it "returns the version" $ do+      let modifiers = unsafeModifiers [AddVersionFlag "1.0.0"]+      getVersion modifiers `shouldBe` Just "1.0.0"++data Foo+  = Foo {+    bar :: String+  }+  deriving (Generic)++data Overlap+  = Overlap {+    foo :: String,+    fooo :: String+  }+  deriving (Generic)

@@ -15,13 +15,13 @@ spec :: Spec spec = do   describe "runParser" $ do-    it "foo" $ do+    it "works" $ do       let fa :: Parser phase Int           fa = Parser {             parserDefault = Nothing,             parserOptions = [],             parserNonOptions =-              (NonOptionsParser "type" (\ (s : r) -> (, r) <$> Success (const $ Just $ read s))) :+              (NonOptionsParser "type" False (\ (s : r) -> (, r) <$> Success (const $ Just $ read s))) :               [],             parserConvert = \ (Just x) -> return x           }

@@ -0,0 +1,206 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module WithCli.Pure.RecordSpec where++import           Prelude ()+import           Prelude.Compat++import           Control.Exception+import           Data.Foldable (forM_)+import           Data.List (isPrefixOf, isSuffixOf)+import           System.Exit+import           System.IO+import           System.IO.Silently+import           Test.Hspec++import           Util+import           WithCli.Pure++spec :: Spec+spec = do+  part1+  part2+  part3+  part4+  part5++data Foo+  = Foo {+    bar :: Maybe Int,+    baz :: String,+    bool :: Bool+  }+  deriving (Generic, Show, Eq)++instance HasArguments Foo++data NotAllowed+  = NotAllowed1+  | NotAllowed2+  deriving (Generic, Show, Eq)++instance HasArguments NotAllowed++part1 :: Spec+part1 = do+  describe "withCliPure (record types)" $ do+    it "allows optional arguments" $ do+      parse "--baz foo" `shouldBe`+        Success (Foo Nothing "foo" False)++    it "allows boolean flags" $ do+      parse "--bool --baz foo" `shouldBe`+        Success (Foo Nothing "foo" True)++    it "allows to overwrite String options" $ do+      parse "--baz one --baz two"+        `shouldBe` Success (Foo Nothing "two" False)++    context "with invalid arguments" $ do+      it "prints out an error" $ do+        let Errors messages = parse "--no-such-option" :: Result Foo+        messages `shouldBe`+          "unrecognized option `--no-such-option'\n" +++          "missing option: --baz=STRING\n"++      it "prints errors for missing options" $ do+        let Errors messages = parse [] :: Result Foo+        messages `shouldBe` "missing option: --baz=STRING\n"++      it "prints out an error for unparseable options" $ do+        let Errors messages = parse "--bar foo --baz huhu" :: Result Foo+        messages `shouldBe` "cannot parse as INTEGER (optional): foo\n"++      it "complains about unused positional arguments" $ do+        (parse "--baz foo unused" :: Result Foo)+          `shouldBe` Errors "unknown argument: unused\n"++      it "complains about invalid overwritten options" $ do+        let Errors messages = parse "--bar foo --baz huhu --bar 12" :: Result Foo+        messages `shouldBe` "cannot parse as INTEGER (optional): foo\n"++    context "--help" $ do+      it "implements --help" $ do+        let OutputAndExit output = parse "--help" :: Result Foo+        mapM_ (output `shouldContain`) $+          "--bar=INTEGER" : "optional" :+          "--baz=STRING" :+          "--bool" :+          []+        lines output `shouldSatisfy` (not . ("" `elem`))++      it "contains help message about --help" $ do+        let OutputAndExit output = parse "--help" :: Result Foo+        output `shouldContain` "show help and exit"++      it "does not contain trailing spaces" $ do+        output <-+          hCapture_ [stdout] $+          handle (\ ExitSuccess -> return ()) $+          handleResult $ ((parse "--help" :: Result Foo) >> return ())+        forM_ (lines output) $ \ line -> do+          line `shouldSatisfy` (not . (" " `isSuffixOf`))++      it "complains when the options datatype is not allowed" $ do+        let Errors messages = parse "--help" :: Result NotAllowed+        messages `shouldSatisfy` ("getopt-generics doesn't support sum types" `isPrefixOf`)++      it "outputs a header including \"[OPTIONS]\"" $ do+        let OutputAndExit output = parse "--help" :: Result Foo+        output `shouldSatisfy` ("prog-name [OPTIONS]\n" `isPrefixOf`)++data ListOptions+  = ListOptions {+    multiple :: [Int]+  }+  deriving (Generic, Show, Eq)++instance HasArguments ListOptions++part2 :: Spec+part2 = do+  describe "parseArguments" $ do+    it "allows to interpret multiple uses of the same option as lists" $ do+      parse "--multiple 23 --multiple 42"+        `shouldBe` Success (ListOptions [23, 42])++    it "complains about invalid list arguments" $ do+      let Errors errs =+            parse "--multiple foo --multiple 13" :: Result ListOptions+      errs `shouldBe` "cannot parse as INTEGER (multiple possible): foo\n"++data CamelCaseOptions+  = CamelCaseOptions {+    camelCase :: String+  }+  deriving (Generic, Show, Eq)++instance HasArguments CamelCaseOptions++part3 :: Spec+part3 = do+  describe "parseArguments" $ do+    it "turns camelCase selectors to lowercase and seperates with a dash" $ do+      parse "--camel-case foo" `shouldBe` Success (CamelCaseOptions "foo")++    it "help does not contain camelCase flags" $ do+      let OutputAndExit output :: Result CamelCaseOptions+            = parse "--help"+      output `shouldNotContain` "camelCase"+      output `shouldContain` "camel-case"++    it "error messages don't contain camelCase flags" $ do+      let Errors errs :: Result CamelCaseOptions+            = parse "--bla"+      show errs `shouldNotContain` "camelCase"+      show errs `shouldContain` "camel-case"++data WithUnderscore+  = WithUnderscore {+    _withUnderscore :: String+  }+  deriving (Generic, Show, Eq)++instance HasArguments WithUnderscore++part4 :: Spec+part4 = do+  describe "parseArguments" $ do+    it "ignores leading underscores in field names" $ do+      parse "--with-underscore foo"+        `shouldBe` Success (WithUnderscore "foo")++data WithoutSelectors+  = WithoutSelectors String Bool Int+  deriving (Eq, Show, Generic)++instance HasArguments WithoutSelectors++part5 :: Spec+part5 = do+  describe "parseArguments" $ do+    context "WithoutSelectors" $ do+      it "populates fields without selectors from positional arguments" $ do+        parse "foo true 23"+          `shouldBe` Success (WithoutSelectors "foo" True 23)++      it "has good help output for positional arguments" $ do+        let OutputAndExit output = parse "--help" :: Result WithoutSelectors+        output `shouldSatisfy` ("prog-name [OPTIONS] STRING BOOL INTEGER" `isPrefixOf`)++      it "has good error messages for missing positional arguments" $ do+        (parse "foo" :: Result WithoutSelectors)+          `shouldBe` Errors+            ("missing argument of type BOOL\n" +++             "missing argument of type INTEGER\n")++      it "complains about additional positional arguments" $ do+        (parse "foo true 5 bar" :: Result WithoutSelectors)+          `shouldBe` Errors "unknown argument: bar\n"++      it "allows to use tuples" $ do+        (parse "42 bar" :: Result (Int, String))+          `shouldBe` Success (42, "bar")

@@ -0,0 +1,33 @@++module WithCli.PureSpec where++import           Test.Hspec++import           WithCli.Pure++spec :: Spec+spec = do+  describe "withCliPure" $ do+    it "works for no arguments" $ do+      let f :: String+          f = "foo"+      withCliPure "progName" [] [] f `shouldBe` Success "foo"+      withCliPure "progName" [] ["-h"] f `shouldBe` ((OutputAndExit $ unlines $+        "progName [OPTIONS]" :+        "  -h  --help  show help and exit" :+        []) :: Result String)++    it "works for one argument" $ do+      let f :: Int -> String+          f = show+      withCliPure "progName" [] ["42"] f `shouldBe` Success "42"+      withCliPure "progName" [] ["-h"] f `shouldBe` ((OutputAndExit $ unlines $+        "progName [OPTIONS] INTEGER" :+        "  -h  --help  show help and exit" :+        []) :: Result String)++    it "works for two arguments" $ do+      let f :: Int -> String -> (Int, String)+          f n s = (n, s)+      withCliPure "progName" [] ["42", "foo"] f `shouldBe`+        Success (42 :: Int, "foo")

@@ -17,9 +17,14 @@   describe "Result" $ do     context ">>" $ do       it "collects errors" $ do-        (Errors ["foo"] >> Errors ["bar"] :: Result ())-          `shouldBe` Errors ["foo", "bar"]+        (Errors "foo" >> Errors "bar" :: Result ())+          `shouldBe` Errors "foo\nbar" +    describe "|>" $ do+      it "shortcuts directly without collecting other errors" $ do+        (Errors "foo" |> Errors "bar" :: Result ()) `shouldBe` Errors "foo"+        return () |> return () `shouldBe` return ()+   describe "handleResult" $ do     context "OutputAndExit" $ do       it "throws ExitSuccess" $ do@@ -28,18 +33,18 @@      context "Errors" $ do       it "throws an ExitFailure" $ do-        handleResult (Errors ["foo"])+        handleResult (Errors "foo")           `shouldThrow` (== ExitFailure 1) -  describe "sanitize" $ do+  describe "sanitizeMessage" $ do     it "removes empty lines" $ do       property $ \ (unlines -> s) -> do-        sanitize s `shouldNotContain` "\n\n"+        sanitizeMessage s `shouldNotContain` "\n\n"      it "adds a newline at the end if missing" $ do       property $ \ (unlines -> s) ->-        not (null (sanitize s)) ==>-        lastMay (sanitize s) `shouldBe` Just '\n'+        not (null (sanitizeMessage s)) ==>+        lastMay (sanitizeMessage s) `shouldBe` Just '\n'      it "only strips spaces" $ do       property $ \ (unlines -> s) -> do@@ -48,8 +53,8 @@                 "" -> ""                 x | lastMay x == Just '\n' -> x                 x -> x ++ "\n"-          filter (not . isSpace) (sanitize s) `shouldBe` filter (not . isSpace) expected+          filter (not . isSpace) (sanitizeMessage s) `shouldBe` filter (not . isSpace) expected      it "removes trailing spaces" $ do       property $ \ (unlines -> s) -> do-        sanitize s `shouldSatisfy` (not . (" \n" `isInfixOf`))+        sanitizeMessage s `shouldSatisfy` (not . (" \n" `isInfixOf`))

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-}  module WithCliSpec where @@ -9,6 +10,16 @@  import           WithCli +data Foo+  = Foo {+    bar :: Maybe Int,+    baz :: String,+    bool :: Bool+  }+  deriving (Eq, Show, Generic)++instance HasArguments Foo+ spec :: Spec spec = do   describe "withCli" $ do@@ -35,11 +46,53 @@       it "error parsing" $ do         let main :: Int -> IO ()             main n = putStrLn ("error: " ++ show n)-        output <- hCapture_ [stderr] (withArgs (words "12 foo") (withCli main) `shouldThrow` (== ExitFailure 1))+        output <- hCapture_ [stderr] (withArgs (words "12 foo") (withCli main)+          `shouldThrow` (== ExitFailure 1))         output `shouldBe` "unknown argument: foo\n" -      it "handle Maybes as positional arguments with a proper error message" $ do+      context "record types" $ do+        it "parses command line arguments" $ do+          withArgs (words "--bar 4 --baz foo") $+            withCli $ \ foo -> do+              foo `shouldBe` Foo (Just 4) "foo" False++    context "optional positional arguments with Maybe" $ do+      it "allows optional positional arguments" $ do         let main :: Maybe Int -> IO ()+            main = print+        (capture_ $ withCli main)+          `shouldReturn` "Nothing\n"+        (capture_ $ withArgs ["23"] $ withCli main)+          `shouldReturn` "Just 23\n"++      it "allows multiple optional positional arguments" $ do+        let main :: Maybe Int -> Maybe String -> IO ()+            main i s = print (i, s)+        (capture_ $ withCli main)+          `shouldReturn` "(Nothing,Nothing)\n"+        (capture_ $ withArgs ["23"] $ withCli main)+          `shouldReturn` "(Just 23,Nothing)\n"+        (capture_ $ withArgs ["23", "foo"] $ withCli main)+          `shouldReturn` "(Just 23,Just \"foo\")\n"++      it "allows optional positional arguments after non-optional arguments" $ do+        let main :: Int -> Maybe String -> IO ()+            main i s = print (i, s)+        (hCapture_ [stderr] $ withCli main `shouldThrow` (== ExitFailure 1))+          `shouldReturn` "missing argument of type INTEGER\n"+        (capture_ $ withArgs ["23"] $ withCli main)+          `shouldReturn` "(23,Nothing)\n"+        (capture_ $ withArgs ["23", "foo"] $ withCli main)+          `shouldReturn` "(23,Just \"foo\")\n"++      it "disallows optional positional arguments before non-optional ones with a proper error message" $ do+        let main :: Maybe Int -> String -> IO ()             main = error "main"-        output <- hCapture_ [stderr] (withCli main `shouldThrow` (== ExitFailure 1))-        output `shouldBe` "cannot use Maybes for positional arguments\n"+        hCapture_ [stderr] (withCli main `shouldThrow` (== ExitFailure 1))+          `shouldReturn` "cannot use Maybes for optional arguments before any non-optional arguments\n"++      it "shows optional arguments with nested square brackets in help output" $ do+        let main :: Int -> Maybe String -> Maybe String -> IO ()+            main = error "main"+        output <- capture_ (withArgs ["-h"] (withCli main) `shouldThrow` (== ExitSuccess))+        output `shouldContain` "[OPTIONS] INTEGER [STRING [STRING]]"