getopt-generics 0.6.3 → 0.7
raw patch · 9 files changed
+389/−155 lines, 9 filesnew-uploaderPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ System.Console.GetOpt.Generics: instance [overlap ok] Option Double
+ System.Console.GetOpt.Generics: instance [overlap ok] Option Float
+ System.Console.GetOpt.Generics: instance [overlap ok] Option Integer
- System.Console.GetOpt.Generics: UseForPositionalArguments :: String -> Modifier
+ System.Console.GetOpt.Generics: UseForPositionalArguments :: String -> String -> Modifier
Files
- getopt-generics.cabal +3/−2
- src/System/Console/GetOpt/Generics.hs +177/−93
- src/System/Console/GetOpt/Generics/Internal.hs +5/−15
- src/System/Console/GetOpt/Generics/Modifier.hs +19/−9
- src/System/Console/GetOpt/Generics/Result.hs +21/−1
- test/ExamplesSpec.hs +2/−2
- test/System/Console/GetOpt/Generics/ModifierSpec.hs +3/−3
- test/System/Console/GetOpt/Generics/ResultSpec.hs +12/−0
- test/System/Console/GetOpt/GenericsSpec.hs +147/−30
getopt-generics.cabal view
@@ -1,12 +1,13 @@--- This file has been generated from package.yaml by hpack.+-- This file has been generated from package.yml by hpack version 0.2.0. -- -- see: https://github.com/sol/hpack name: getopt-generics-version: 0.6.3+version: 0.7 synopsis: Simple command line argument parsing description: "getopt-generics" tries to make it very simple to create command line argument parsers. An introductory example can be found in the <https://github.com/zalora/getopt-generics#getopt-generics README>. category: Console, System+homepage: https://github.com/zalora/getopt-generics#readme bug-reports: https://github.com/zalora/getopt-generics/issues author: Linh Nguyen, Sönke Hahn maintainer: linh.nguyen@zalora.com, soenke.hahn@zalora.com
src/System/Console/GetOpt/Generics.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE RankNTypes #-}@@ -15,6 +16,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -- | @getopt-generics@ tries to make it very simple to create command line@@ -39,24 +41,22 @@ Proxy(..) ) where +import Data.Orphans () import Prelude () import Prelude.Compat-import Data.Orphans () -import Control.Monad (when) import Data.Char import Data.List import Data.Maybe+import Data.Proxy import Data.Typeable import Generics.SOP import System.Console.GetOpt import System.Environment-import System.Exit-import System.IO import Text.Read.Compat -import System.Console.GetOpt.Generics.Modifier import System.Console.GetOpt.Generics.Internal+import System.Console.GetOpt.Generics.Modifier import System.Console.GetOpt.Generics.Result -- | Parses command line arguments (gotten from 'withArgs') and returns the@@ -79,38 +79,36 @@ modifiedGetArguments modifiers = do args <- getArgs progName <- getProgName- case parseArguments progName modifiers args of- Success a -> return a- OutputAndExit message -> do- putStrLn message- exitWith ExitSuccess- Errors errs -> do- mapM_ (hPutStrLn stderr) errs- exitWith $ ExitFailure 1+ handleResult $ parseArguments progName modifiers args --- | Pure variant of 'getArguments'. Also allows to declare 'Modifier's.+-- | Pure variant of 'getArguments'. -- -- Does not throw any exceptions. parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>- String -> [Modifier] -> [String] -> Result a-parseArguments header modifiersList args = do+ 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 modifiersList args = do (modifiers, datatypeInfo) <- (,) <$> mkModifiers modifiersList <*> normalizedDatatypeInfo (Proxy :: Proxy a) case datatypeInfo of ADT typeName _ (constructorInfo :* Nil) -> case constructorInfo of- (Record _ fields) -> processFields header modifiers args fields+ (Record _ fields) -> processFields progName modifiers args+ (hliftA (Comp . Selector) fields) Constructor{} ->- err typeName "constructors without field labels"+ processFields progName modifiers args (hpure (Comp NoSelector)) Infix{} -> err typeName "infix constructors" ADT typeName _ Nil -> err typeName "empty data types" ADT typeName _ (_ :* _ :* _) ->- err typeName "sum-types"+ err typeName "sum types" Newtype _ _ (Record _ fields) ->- processFields header modifiers args fields+ processFields progName modifiers args+ (hliftA (Comp . Selector) fields) Newtype typeName _ (Constructor _) -> err typeName "constructors without field labels" where@@ -118,54 +116,50 @@ Errors ["getopt-generics doesn't support " ++ message ++ " (" ++ typeName ++ ")."] +data Field a+ = NoSelector+ | Selector a+ processFields :: forall a xs . (Generic a, Code a ~ '[xs], SingI xs, All Option xs) =>- String -> Modifiers -> [String] -> NP FieldInfo xs -> Result a-processFields header modifiers args fields =- mkInitialFieldStates modifiers fields >>= \ initialFieldStates ->+ String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result a+processFields progName modifiers args fields = do+ initialFieldStates <- mkInitialFieldStates modifiers fields - showHelp *>+ showHelp let (options, arguments, parseErrors) = getOpt Permute (mkOptDescrs modifiers fields) args- in - reportParseErrors parseErrors *>+ reportGetOptErrors parseErrors - reportInvalidPositionalArguments arguments *>+ let (withPositionalArguments, additionalArgumentsErrors) =+ fillInPositionalArguments arguments $+ project options initialFieldStates+ either Errors return additionalArgumentsErrors - produceResult initialFieldStates options arguments+ to . SOP . Z <$> collectResult withPositionalArguments where showHelp :: Result ()- showHelp = helpWrapper header modifiers args fields+ showHelp = helpWrapper progName modifiers args fields - reportParseErrors :: [String] -> Result ()- reportParseErrors parseErrors = case parseErrors of+ reportGetOptErrors :: [String] -> Result ()+ reportGetOptErrors parseErrors = case parseErrors of [] -> pure () errs -> Errors errs - reportInvalidPositionalArguments :: [String] -> Result ()- reportInvalidPositionalArguments arguments =- when (not $ hasPositionalArgumentsField modifiers) $- case arguments of- [] -> pure ()- _ -> Errors (map ("unknown argument: " ++) arguments)-- produceResult :: NP FieldState xs -> [NS FieldState xs] -> [String] -> Result a- produceResult initialFieldStates options arguments =- (to . SOP . Z) <$>- collectResult arguments (project options initialFieldStates)---mkOptDescrs :: forall xs . All Option xs =>- Modifiers -> NP FieldInfo xs -> [OptDescr (NS FieldState xs)]-mkOptDescrs modifiers fields =- mapMaybe toOptDescr $ sumList $ npMap (mkOptDescr modifiers) fields+-- Creates a list of NS where every element corresponds to one field. To be+-- used by 'getOpt'.+mkOptDescrs :: forall xs . (SingI xs, All Option xs) =>+ Modifiers -> NP (Field :.: FieldInfo) xs -> [OptDescr (NS FieldState xs)]+mkOptDescrs modifiers =+ mapMaybe toOptDescr . apInjs_NP . hcliftA (Proxy :: Proxy Option) (mkOptDescr modifiers) newtype OptDescrE a = OptDescrE (Maybe (OptDescr (FieldState a))) -mkOptDescr :: forall a . Option a => Modifiers -> FieldInfo a -> OptDescrE a-mkOptDescr modifiers (FieldInfo name) = OptDescrE $+mkOptDescr :: forall a . Option a => Modifiers -> (Field :.: FieldInfo) a -> OptDescrE a+mkOptDescr _modifiers (Comp NoSelector) = OptDescrE Nothing+mkOptDescr modifiers (Comp (Selector (FieldInfo name))) = OptDescrE $ if isPositionalArgumentsField modifiers name then Nothing else Just $ Option@@ -179,20 +173,24 @@ toOptDescr (Z (OptDescrE Nothing)) = Nothing toOptDescr (S a) = fmap (fmap S) (toOptDescr a) +-- Initializes an NP of empty fields to be filled in later.+-- Contains only default values. mkInitialFieldStates :: forall xs . (SingI xs, All Option xs) =>- Modifiers -> NP FieldInfo xs -> Result (NP FieldState xs)+ Modifiers -> NP (Field :.: FieldInfo) xs -> Result (NP FieldState xs) mkInitialFieldStates modifiers fields = case (sing :: Sing xs, fields) of (SNil, Nil) -> return Nil- (SCons, FieldInfo name :* r) ->+ (SCons, Comp (Selector (FieldInfo name)) :* r) -> (:*) <$> inner name <*> mkInitialFieldStates modifiers r- _ -> uninhabited "mkEmpty"+ (SCons, Comp NoSelector :* r) ->+ (:*) <$> Success PositionalArgument <*> mkInitialFieldStates modifiers r+ _ -> uninhabited "mkInitialFieldStates" where inner :: forall x . Option x => String -> Result (FieldState x) inner name = if isPositionalArgumentsField modifiers name then case cast (id :: FieldState x -> FieldState x) of (Just id' :: Maybe (FieldState [String] -> FieldState x)) ->- return $ id' PositionalArguments+ Success $ id' PositionalArguments Nothing -> Errors ["UseForPositionalArguments can only be used " ++ "for fields of type [String] not " ++@@ -204,9 +202,10 @@ data HelpFlag = HelpFlag -helpWrapper :: (All Option xs) =>- String -> Modifiers -> [String] -> NP FieldInfo xs -> Result ()-helpWrapper header modifiers args fields =+-- Outputs the help if the help flag is given.+helpWrapper :: (SingI xs, All Option xs) =>+ String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result ()+helpWrapper progName modifiers args fields = case getOpt Permute [helpOption] args of ([], _, _) -> return () -- no help flag given@@ -222,36 +221,82 @@ toOptDescrUnit :: [OptDescr a] -> [OptDescr ()] toOptDescrUnit = map (fmap (const ())) + header :: String+ header = unwords $+ progName :+ "[OPTIONS]" :+ positionalArgumentHelp fields +++ maybe [] (\ t -> ["[" ++ t ++ "]"])+ (getPositionalArgumentType modifiers) +++ []++positionalArgumentHelp :: (All Option xs) => NP (Field :.: FieldInfo) xs -> [String]+positionalArgumentHelp (p@(Comp NoSelector) :* r) =+ argumentType (toProxy p) : positionalArgumentHelp r+positionalArgumentHelp (_ :* r) = positionalArgumentHelp r+positionalArgumentHelp Nil = []+ stripTrailingSpaces :: String -> String stripTrailingSpaces = unlines . map stripLines . lines where stripLines = reverse . dropWhile isSpace . reverse --- * helper functions for NS and NP--collectResult :: [String] -> NP FieldState xs -> Result (NP I xs)-collectResult positionalArguments np = case np of- Nil -> Success Nil- (a :* r) -> (:*) <$> inner a <*> collectResult positionalArguments r+-- Fills in the positional arguments in the NP that already contains the flag+-- values. Fills in FieldErrors in case of+-- - parse errors and+-- - missing positional arguments.+-- The returned Either contains errors in case of too many positional arguments.+fillInPositionalArguments :: (All Option xs) =>+ [String] -> NP FieldState xs -> (NP FieldState xs, Either [String] ())+fillInPositionalArguments = inner . Just where- inner :: FieldState a -> Result (I a)- inner (FieldSuccess v) = Success (I v)- inner (ParseErrors errs) = Errors errs- inner (Unset err) = Errors [err]- inner PositionalArguments = Success (I positionalArguments)+ inner :: All Option xs =>+ Maybe [String] -> NP FieldState xs -> (NP FieldState xs, Either [String] ())+ inner arguments fields = case (arguments, fields) of -npMap :: (All Option xs) => (forall a . Option a => f a -> g a) -> NP f xs -> NP g xs-npMap _ Nil = Nil-npMap f (a :* r) = f a :* npMap f r+ (Just arguments, PositionalArguments :* r) -> FieldSuccess arguments `cons` inner Nothing r+ (Nothing, PositionalArguments :* r) ->+ FieldErrors ["UseForPositionalArguments can only be used once"] `cons` inner Nothing r -sumList :: NP f xs -> [NS f xs]-sumList Nil = []-sumList (a :* r) = Z a : map S (sumList r)+ (Just (argument : arguments), PositionalArgument :* r) ->+ case parseArgumentEither argument of+ Right a -> FieldSuccess a `cons` inner (Just arguments) r+ Left err -> FieldErrors [err] `cons` inner (Just arguments) r+ (Just [], p@PositionalArgument :* r) ->+ FieldErrors ["missing argument of type " ++ argumentType (toProxy p)]+ `cons` inner (Just []) r+ (Nothing, PositionalArgument :* _) ->+ impossible "fillInPositionalArguments" + (arguments, a :* r) -> a `cons` inner arguments r+ (Just [], Nil) -> (Nil, Right ())+ (Nothing, Nil) -> (Nil, Right ())+ (Just arguments@(_ : _), Nil) ->+ (Nil, Left (map (\ arg -> "unknown argument: " ++ arg) arguments))++ cons :: FieldState x -> (NP FieldState xs, r) -> (NP FieldState (x ': xs), r)+ cons fieldState (arguments, r) = (fieldState :* arguments, r)++-- Collects all FieldStates into a Result NP. If any errors are contained they+-- will be accumulated.+collectResult :: (SingI xs) => NP FieldState xs -> Result (NP I xs)+collectResult input =+ hsequence $ hliftA inner input+ where+ inner :: FieldState x -> Result x+ inner s = case s of+ FieldSuccess v -> Success v+ FieldErrors errs -> Errors errs+ Unset err -> Errors [err]+ PositionalArguments -> impossible "collectResult"+ PositionalArgument -> impossible "collectResult"++-- * helper functions for NS and NP+ project :: (SingI xs, All Option xs) => [NS FieldState xs] -> NP FieldState xs -> NP FieldState xs-project sums empty =- foldl' inner empty sums+project sums start =+ foldl' inner start sums where inner :: (All Option xs) => NP FieldState xs -> NS FieldState xs -> NP FieldState xs@@ -265,13 +310,17 @@ uninhabited :: String -> a uninhabited = impossible +toProxy :: f a -> Proxy a+toProxy = const Proxy+ -- * possible field types data FieldState a where Unset :: String -> FieldState a- ParseErrors :: [String] -> FieldState a+ FieldErrors :: [String] -> FieldState a FieldSuccess :: a -> FieldState a PositionalArguments :: FieldState [String]+ PositionalArgument :: FieldState a deriving (Typeable) -- | Type class for all allowed field types.@@ -302,28 +351,30 @@ _accumulate :: a -> a -> a _accumulate _ x = x +parseArgumentEither :: forall a . Option a => String -> Either String a+parseArgumentEither s =+ maybe+ (Left ("cannot parse as " ++ argumentType (Proxy :: Proxy a) ++ ": " ++ s))+ Right+ (parseArgument s)+ parseAsFieldState :: forall a . Option a => String -> FieldState a-parseAsFieldState s = case parseArgument s of- Just a -> FieldSuccess a- Nothing -> ParseErrors $ pure $- "cannot parse as " ++ argumentType (Proxy :: Proxy a) ++ ": " ++ s+parseAsFieldState s = either+ (\ err -> FieldErrors [err])+ FieldSuccess+ (parseArgumentEither s) combine :: Option a => FieldState a -> FieldState a -> FieldState a combine _ (Unset _) = impossible "combine" combine _ PositionalArguments = impossible "combine"-combine (ParseErrors e) (ParseErrors f) = ParseErrors (e ++ f)-combine (ParseErrors e) _ = ParseErrors e+combine _ PositionalArgument = impossible "combine"+combine (FieldErrors e) (FieldErrors f) = FieldErrors (e ++ f)+combine (FieldErrors e) _ = FieldErrors e combine (Unset _) x = x-combine (FieldSuccess _) (ParseErrors e) = ParseErrors e+combine (FieldSuccess _) (FieldErrors e) = FieldErrors e combine (FieldSuccess a) (FieldSuccess b) = FieldSuccess (_accumulate a b) combine PositionalArguments _ = PositionalArguments--instance Option Bool where- argumentType _ = "bool"- parseArgument = impossible "Option.Bool.parseArguments"-- _toOption = NoArg (FieldSuccess True)- _emptyOption _ = FieldSuccess False+combine PositionalArgument _ = PositionalArgument instance Option a => Option [a] where argumentType Proxy = argumentType (Proxy :: Proxy a) ++ " (multiple possible)"@@ -340,10 +391,43 @@ Nothing -> Nothing _emptyOption _ = FieldSuccess Nothing +instance Option Bool where+ argumentType _ = "BOOL"++ parseArgument :: String -> Maybe Bool+ parseArgument s+ | map toLower s == "true" = Just True+ | map toLower s == "false" = Just False+ | otherwise = case readMaybe s of+ Just (n :: Integer) -> Just (n > 0)+ Nothing -> Nothing++ _toOption = NoArg (FieldSuccess True)+ _emptyOption _ = FieldSuccess False+ instance Option String where- argumentType Proxy = "string"+ argumentType Proxy = "STRING" parseArgument = Just instance Option Int where- argumentType _ = "integer"+ argumentType _ = "INTEGER" parseArgument = readMaybe++instance Option Integer where+ argumentType _ = "INTEGER"+ parseArgument = readMaybe++readNumber :: (RealFloat n, Read n) => String -> Maybe n+readNumber s = case readMaybe s of+ Just n -> Just n+ Nothing+ | "." `isPrefixOf` s -> readMaybe ("0" ++ s)+ | otherwise -> Nothing++instance Option Float where+ argumentType _ = "NUMBER"+ parseArgument = readNumber++instance Option Double where+ argumentType _ = "NUMBER"+ parseArgument = readNumber
src/System/Console/GetOpt/Generics/Internal.hs view
@@ -5,7 +5,9 @@ module System.Console.GetOpt.Generics.Internal where -import Control.Applicative+import Prelude ()+import Prelude.Compat+ import Data.Char import Generics.SOP @@ -23,7 +25,7 @@ -> DatatypeInfo xss -> m (DatatypeInfo xss) mapFieldInfoM f info = case info of (ADT mod name constructors) ->- ADT mod name <$> (mapConsInfo (mapSingleCons f) constructors)+ ADT mod name <$> hsequence' (hliftA (Comp . mapSingleCons f) constructors) (Newtype mod name constructor) -> Newtype mod name <$> (mapSingleCons f constructor) where@@ -31,21 +33,9 @@ (forall a . FieldInfo a -> m (FieldInfo a)) -> ConstructorInfo xs -> m (ConstructorInfo xs) mapSingleCons f c = case c of- (Record name fields) -> Record name <$> (mapFieldInfo f fields)+ (Record name fields) -> Record name <$> hsequence' (hliftA (Comp . f) fields) cons@Infix{} -> pure cons cons@Constructor{} -> pure cons-- mapConsInfo :: forall m xs . Applicative m =>- (forall a . ConstructorInfo a -> m (ConstructorInfo a))- -> NP ConstructorInfo xs -> m (NP ConstructorInfo xs)- mapConsInfo _ Nil = pure Nil- mapConsInfo f (a :* r) = (:*) <$> f a <*> mapConsInfo f r-- mapFieldInfo :: forall m xs . Applicative m =>- (forall a . FieldInfo a -> m (FieldInfo a))- -> NP FieldInfo xs -> m (NP FieldInfo xs)- mapFieldInfo _ Nil = pure Nil- mapFieldInfo f (a :* r) = (:*) <$> f a <*> mapFieldInfo f r normalizeFieldName :: String -> Result String normalizeFieldName s =
src/System/Console/GetOpt/Generics/Modifier.hs view
@@ -10,6 +10,7 @@ mkLongOption, hasPositionalArgumentsField, isPositionalArgumentsField,+ getPositionalArgumentType, getHelpText, deriveShortOptions,@@ -19,7 +20,9 @@ insertWith, ) where -import Control.Applicative+import Prelude ()+import Prelude.Compat+ import Control.Monad import Data.Char import Data.Maybe@@ -36,10 +39,14 @@ | RenameOption String String -- ^ @RenameOption fieldName customName@ renames the option generated -- through the @fieldName@ by @customName@.- | UseForPositionalArguments String- -- ^ @UseForPositionalArguments fieldName@ 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']@.+ | 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@.@@ -48,7 +55,7 @@ data Modifiers = Modifiers { _shortOptions :: [(String, [Char])], _renamings :: [(String, String)],- positionalArgumentsField :: Maybe String,+ positionalArgumentsField :: Maybe (String, String), helpTexts :: [(String, String)] } deriving (Show, Eq, Ord)@@ -66,9 +73,9 @@ (RenameOption from to) -> do fromNormalized <- normalizeFieldName from return $ Modifiers shorts (insert fromNormalized to renamings) args help- (UseForPositionalArguments option) -> do+ (UseForPositionalArguments option typ) -> do normalized <- normalizeFieldName option- return $ Modifiers shorts renamings (Just normalized) help+ return $ Modifiers shorts renamings (Just (normalized, map toUpper typ)) help (AddOptionHelp option helpText) -> do normalized <- normalizeFieldName option return $ Modifiers shorts renamings args (insert normalized helpText help)@@ -86,7 +93,10 @@ isPositionalArgumentsField :: Modifiers -> String -> Bool isPositionalArgumentsField modifiers field =- Just field == positionalArgumentsField modifiers+ Just field == fmap fst (positionalArgumentsField modifiers)++getPositionalArgumentType :: Modifiers -> Maybe String+getPositionalArgumentType = fmap snd . positionalArgumentsField getHelpText :: Modifiers -> String -> String getHelpText modifiers field = fromMaybe "" (lookup field (helpTexts modifiers))
src/System/Console/GetOpt/Generics/Result.hs view
@@ -2,8 +2,13 @@ module System.Console.GetOpt.Generics.Result where -import Control.Applicative+import Prelude ()+import Prelude.Compat +import Data.List+import System.Exit+import System.IO+ -- | Type to wrap results from the pure parsing functions. data Result a = Success a@@ -37,3 +42,18 @@ OutputAndExit message >>= _ = OutputAndExit message (>>) = (*>)++handleResult :: Result a -> IO a+handleResult result = case result of+ Success a -> return a+ OutputAndExit message -> do+ putStr message+ exitWith ExitSuccess+ Errors errs -> do+ mapM_ (hPutStr stderr . addNewlineIfMissing) errs+ exitWith $ ExitFailure 1++addNewlineIfMissing :: String -> String+addNewlineIfMissing s+ | "\n" `isSuffixOf` s = s+ | otherwise = s ++ "\n"
test/ExamplesSpec.hs view
@@ -3,8 +3,8 @@ import Test.Hspec -import Example ()-import Readme ()+import Example ()+import Readme () spec :: Spec spec = return ()
test/System/Console/GetOpt/Generics/ModifierSpec.hs view
@@ -6,7 +6,7 @@ import Data.Proxy import qualified GHC.Generics import Test.Hspec-import Test.QuickCheck hiding (Result)+import Test.QuickCheck hiding (Result) import System.Console.GetOpt.Generics import System.Console.GetOpt.Generics.Modifier@@ -35,9 +35,9 @@ describe "parseArguments" $ do it "allows to specify a flag specific help" $ do let OutputAndExit output =- parseArguments "header" [AddOptionHelp "bar" "bar help text"]+ parseArguments "prog-name" [AddOptionHelp "bar" "bar help text"] (words "--help") :: Result Foo- output `shouldContain` "--bar=string bar help text"+ output `shouldContain` "--bar=STRING bar help text" data Foo = Foo {
test/System/Console/GetOpt/Generics/ResultSpec.hs view
@@ -2,6 +2,10 @@ module System.Console.GetOpt.Generics.ResultSpec where +import Control.Exception+import System.Exit+import System.IO+import System.IO.Silently import Test.Hspec import System.Console.GetOpt.Generics.Result@@ -13,3 +17,11 @@ it "collects errors" $ do (Errors ["foo"] >> Errors ["bar"] :: Result ()) `shouldBe` Errors ["foo", "bar"]++ describe "handleResult" $ do+ it "appends '\\n' at the end of error messages if missing" $ do+ output <- hCapture_ [stderr] $ do+ handle (\ (_ :: ExitCode) -> return ()) $ do+ _ <- handleResult (Errors ["foo", "bar\n", "baz"])+ return ()+ output `shouldBe` "foo\nbar\nbaz\n"
test/System/Console/GetOpt/GenericsSpec.hs view
@@ -4,17 +4,21 @@ module System.Console.GetOpt.GenericsSpec where +import Prelude ()+import Prelude.Compat+ import Control.Exception-import Data.Foldable (forM_)-import Data.List+import Data.Foldable (forM_)+import Data.List (isPrefixOf, isSuffixOf) import Data.Typeable-import qualified GHC.Generics as GHC+import qualified GHC.Generics as GHC import System.Environment import System.Exit import System.IO import System.IO.Silently import Test.Hspec import Test.Hspec.Expectations.Contrib+import Test.QuickCheck hiding (Result(..)) import System.Console.GetOpt.Generics @@ -26,6 +30,7 @@ part4 part5 part6+ part7 data Foo = Foo {@@ -38,7 +43,9 @@ instance Generic Foo instance HasDatatypeInfo Foo -data NotAllowed = NotAllowed+data NotAllowed+ = NotAllowed1+ | NotAllowed2 deriving (GHC.Generic, Show, Eq) instance Generic NotAllowed@@ -71,29 +78,33 @@ withArgs (words "--no-such-option") $ do _ :: Foo <- getArguments return ()- output `shouldContain` "unrecognized"- output `shouldContain` "--no-such-option"+ output `shouldBe` "unrecognized option `--no-such-option'\nmissing option: --baz=STRING\n" it "prints errors for missing options" $ do output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ withArgs [] $ do _ :: Foo <- getArguments return ()- output `shouldContain` "missing option: --baz=string"+ output `shouldContain` "missing option: --baz=STRING"+ output `shouldSatisfy` ("\n" `isSuffixOf`) it "prints out an error for unparseable options" $ do output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ withArgs (words "--bar foo --baz huhu") $ do _ :: Foo <- getArguments return ()- output `shouldContain` "cannot parse as integer (optional): foo"+ output `shouldBe` "cannot parse as INTEGER (optional): foo\n" + it "complains about unused positional arguments" $ do+ (parseArguments "prog-name" [] (words "--baz foo unused") :: Result Foo)+ `shouldBe` Errors ["unknown argument: unused"]+ it "complains about invalid overwritten options" $ do output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $ withArgs (words "--bar foo --baz huhu --bar 12") $ do _ :: Foo <- getArguments return ()- output `shouldContain` "cannot parse as integer (optional): foo"+ output `shouldBe` "cannot parse as INTEGER (optional): foo\n" context "--help" $ do it "implements --help" $ do@@ -102,10 +113,11 @@ _ :: Foo <- getArguments return () mapM_ (output `shouldContain`) $- "--bar=integer" : "optional" :- "--baz=string" :+ "--bar=INTEGER" : "optional" :+ "--baz=STRING" : "--bool" : []+ lines output `shouldSatisfy` (not . ("" `elem`)) it "throws ExitSuccess" $ do withArgs ["--help"] (getArguments :: IO Foo)@@ -132,8 +144,14 @@ handle (\ (_ :: SomeException) -> return ()) $ do _ :: NotAllowed <- getArguments return ()- output `shouldContain` "doesn't support constructors without field labels"+ output `shouldContain` "getopt-generics doesn't support sum types"+ lines output `shouldSatisfy` (not . ("" `elem`)) + it "outputs a header including \"[OPTIONS]\"" $ do+ let OutputAndExit output =+ parseArguments "prog-name" [] ["--help"] :: Result Foo+ output `shouldSatisfy` ("prog-name [OPTIONS]\n" `isPrefixOf`)+ describe "parseArguments" $ do it "allows to overwrite String options" $ do parseArguments "header" [] (words "--baz one --baz two")@@ -161,7 +179,7 @@ handle (\ (_ :: SomeException) -> return ()) $ do _ :: ListOptions <- getArguments return ()- output `shouldContain` "cannot parse as integer (multiple possible): foo"+ output `shouldBe` "cannot parse as INTEGER (multiple possible): foo\n" data CamelCaseOptions = CamelCaseOptions {@@ -182,37 +200,37 @@ describe "parseArguments" $ do it "help does not contain camelCase flags" $ do let OutputAndExit output :: Result CamelCaseOptions- = parseArguments "header" [] ["--help"]+ = parseArguments "prog-name" [] ["--help"] output `shouldNotContain` "camelCase" output `shouldContain` "camel-case" it "error messages don't contain camelCase flags" $ do let Errors errs :: Result CamelCaseOptions- = parseArguments "header" [] ["--bla"]+ = parseArguments "prog-name" [] ["--bla"] show errs `shouldNotContain` "camelCase" show errs `shouldContain` "camel-case" context "AddShortOption" $ do it "allows modifiers for short options" $ do- parseArguments "header" [AddShortOption "camel-case" 'x'] (words "-x foo")+ parseArguments "prog-name" [AddShortOption "camel-case" 'x'] (words "-x foo") `shouldBe` Success (CamelCaseOptions "foo") it "allows modifiers in camelCase" $ do- parseArguments "header" [AddShortOption "camelCase" 'x'] (words "-x foo")+ parseArguments "prog-name" [AddShortOption "camelCase" 'x'] (words "-x foo") `shouldBe` Success (CamelCaseOptions "foo") let parse :: [String] -> Result CamelCaseOptions- parse = parseArguments "header" [AddShortOption "camelCase" 'x']+ parse = parseArguments "prog-name" [AddShortOption "camelCase" 'x'] it "includes the short option in the help" $ do let OutputAndExit output = parse ["--help"]- output `shouldContain` "-x string"+ output `shouldContain` "-x STRING" context "RenameOption" $ do it "allows to rename options" $ do- parseArguments "header" [RenameOption "camelCase" "bla"] (words "--bla foo")+ parseArguments "prog-name" [RenameOption "camelCase" "bla"] (words "--bla foo") `shouldBe` Success (CamelCaseOptions "foo") - let parse = parseArguments "header"+ let parse = parseArguments "prog-name" [RenameOption "camelCase" "foo", RenameOption "camelCase" "bar"] it "allows to shadow earlier modifiers with later modifiers" $ do parse (words "--bar foo")@@ -226,7 +244,7 @@ show errs `shouldContain` "camel-case" it "allows to address fields in Modifiers in slugified form" $ do- parseArguments "header" [RenameOption "camel-case" "foo"] (words "--foo bar")+ parseArguments "prog-name" [RenameOption "camel-case" "foo"] (words "--foo bar") `shouldBe` Success (CamelCaseOptions "bar") data WithUnderscore@@ -242,7 +260,7 @@ part4 = do describe "parseArguments" $ do it "ignores leading underscores in field names" $ do- parseArguments "header" [] (words "--with-underscore foo")+ parseArguments "prog-name" [] (words "--with-underscore foo") `shouldBe` Success (WithUnderscore "foo") data WithPositionalArguments@@ -255,32 +273,57 @@ instance Generic WithPositionalArguments instance HasDatatypeInfo WithPositionalArguments +data WithMultiplePositionalArguments+ = WithMultiplePositionalArguments {+ positionalArguments1 :: [String],+ positionalArguments2 :: [String],+ someOtherFlag :: Bool+ }+ deriving (GHC.Generic, Show, Eq)++instance Generic WithMultiplePositionalArguments+instance HasDatatypeInfo WithMultiplePositionalArguments+ part5 :: Spec part5 = do describe "parseArguments" $ do context "UseForPositionalArguments" $ do it "allows positionalArguments" $ do- parseArguments "header"- [UseForPositionalArguments "positionalArguments"]+ parseArguments "prog-name"+ [UseForPositionalArguments "positionalArguments" "type"] (words "foo bar --some-flag") `shouldBe` Success (WithPositionalArguments ["foo", "bar"] True) it "disallows to specify the option used for positional arguments" $ do- parseArguments "header"- [UseForPositionalArguments "positionalArguments"]+ parseArguments "prog-name"+ [UseForPositionalArguments "positionalArguments" "type"] (words "--positional-arguments foo") `shouldBe` (Errors ["unrecognized option `--positional-arguments'\n"] :: Result WithPositionalArguments) it "complains about fields that don't have type [String]" $ do- parseArguments "header"- [UseForPositionalArguments "someFlag"]+ parseArguments "prog-name"+ [UseForPositionalArguments "someFlag" "type"] (words "doesn't matter") `shouldBe` (Errors ["UseForPositionalArguments can only be used for fields of type [String] not Bool"] :: Result WithPositionalArguments) + it "includes the type of positional arguments in the help output in upper-case" $ do+ let OutputAndExit output = parseArguments "prog-name"+ [UseForPositionalArguments "positionalArguments" "foo"]+ (words "--help") :: Result WithPositionalArguments+ output `shouldSatisfy` ("prog-name [OPTIONS] [FOO]\n" `isPrefixOf`)++ it "complains about multiple PositionalArguments fields" $ do+ let modifiers =+ UseForPositionalArguments "positionalArguments1" "foo" :+ UseForPositionalArguments "positionalArguments2" "bar" :+ []+ (parseArguments "prog-name" modifiers [] :: Result WithMultiplePositionalArguments)+ `shouldBe` Errors ["UseForPositionalArguments can only be used once"]+ data CustomFields = CustomFields { custom :: Custom,@@ -311,7 +354,81 @@ describe "parseArguments" $ do context "CustomFields" $ do it "allows easy implementation of custom field types" $ do- parseArguments "header" []+ parseArguments "prog-name" [] (words "--custom foo --custom-list bar --custom-maybe baz") `shouldBe` Success (CustomFields CFoo [CBar] (Just CBaz))++data WithoutSelectors+ = WithoutSelectors String Bool Int+ deriving (Eq, Show, GHC.Generic)++instance Generic WithoutSelectors+instance HasDatatypeInfo WithoutSelectors++part7 :: Spec+part7 = do+ describe "parseArguments" $ do+ context "WithoutSelectors" $ do+ it "populates fields without selectors from positional arguments" $ do+ parseArguments "prog-name" [] (words "foo true 23")+ `shouldBe` Success (WithoutSelectors "foo" True 23)++ it "has good help output for positional arguments" $ do+ let OutputAndExit output = parseArguments "prog-name" [] ["--help"] :: Result WithoutSelectors+ output `shouldSatisfy` ("prog-name [OPTIONS] STRING BOOL INTEGER" `isPrefixOf`)++ it "has good error messages for missing positional arguments" $ do+ (parseArguments "prog-name" [] (words "foo") :: Result WithoutSelectors)+ `shouldBe` Errors (+ "missing argument of type BOOL" :+ "missing argument of type INTEGER" :+ [])++ it "complains about additional positional arguments" $ do+ (parseArguments "prog-name" [] (words "foo true 5 bar") :: Result WithoutSelectors)+ `shouldBe` Errors ["unknown argument: bar"]++ it "allows to use tuples" $ do+ (parseArguments "prog-name" [] (words "42 bar") :: Result (Int, String))+ `shouldBe` Success (42, "bar")++ describe "Option.Bool" $ do+ describe "parseArgument" $ do+ it "parses 'true' case-insensitively" $ do+ forM_ ["true", "True", "tRue", "TRUE"] $ \ true ->+ parseArgument true `shouldBe` Just True++ it "parses 'false' case-insensitively" $ do+ forM_ ["false", "False", "falSE", "FALSE"] $ \ true ->+ parseArgument true `shouldBe` Just False++ it "parses every positive integer as true" $ do+ property $ \ (n :: Int) ->+ n > 0 ==>+ parseArgument (show n) `shouldBe` Just True++ it "parses every non-positive integer as false" $ do+ property $ \ (n :: Int) ->+ n <= 0 ==>+ parseArgument (show n) `shouldBe` Just False++ it "doesn't parse 'foo'" $ do+ parseArgument "foo" `shouldBe` (Nothing :: Maybe Bool)++ describe "Option.Double" $ do+ it "parses doubles" $ do+ parseArgument "1.2" `shouldBe` Just (1.2 :: Double)++ it "renders as NUMBER in help and error output" $ do+ argumentType (Proxy :: Proxy Double) `shouldBe` "NUMBER"++ it "parses doubles that start with a dot" $ do+ parseArgument ".4" `shouldBe` Just (0.4 :: Double)++ describe "Option.Float" $ do+ it "parses floats" $ do+ parseArgument "1.2" `shouldBe` Just (1.2 :: Float)++ it "renders as NUMBER in help and error output" $ do+ argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER"