getopt-generics 0.7.1 → 0.7.1.1
raw patch · 9 files changed
+279/−234 lines, 9 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- System.Console.GetOpt.Generics: class (SingI [[*]] (Code a), All [*] (SingI [*]) (Code a)) => Generic a
+ System.Console.GetOpt.Generics: class (SingI [[*]] (Code a), All [*] (SingI [*]) (Code a)) => Generic a where type family Code a :: [[*]]
Files
- getopt-generics.cabal +5/−2
- src/System/Console/GetOpt/Generics.hs +10/−14
- src/System/Console/GetOpt/Generics/Modifier.hs +6/−6
- src/System/Console/GetOpt/Generics/Result.hs +25/−1
- test/ModifiersSpec.hs +61/−0
- test/ModifiersSpec/UseForPositionalArgumentsSpec.hs +69/−0
- test/System/Console/GetOpt/Generics/ResultSpec.hs +39/−0
- test/System/Console/GetOpt/GenericsSpec.hs +51/−211
- test/Util.hs +13/−0
getopt-generics.cabal view
@@ -1,9 +1,9 @@--- This file has been generated from package.yml by hpack version 0.2.0.+-- This file has been generated from package.yaml by hpack version 0.3.2. -- -- see: https://github.com/sol/hpack name: getopt-generics-version: 0.7.1+version: 0.7.1.1 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@@ -48,10 +48,13 @@ System.Console.GetOpt.Generics.Result System.Console.GetOpt.Generics ExamplesSpec+ ModifiersSpec.UseForPositionalArgumentsSpec+ ModifiersSpec System.Console.GetOpt.Generics.InternalSpec System.Console.GetOpt.Generics.ModifierSpec System.Console.GetOpt.Generics.ResultSpec System.Console.GetOpt.GenericsSpec+ Util Example Readme build-depends:
src/System/Console/GetOpt/Generics.hs view
@@ -38,6 +38,8 @@ -- * Re-exports from "Generics.SOP" Generic, HasDatatypeInfo,+ All2,+ Code, Proxy(..) ) where @@ -113,7 +115,7 @@ err typeName "constructors without field labels" where err typeName message =- Errors ["getopt-generics doesn't support " ++ message +++ errors ["getopt-generics doesn't support " ++ message ++ " (" ++ typeName ++ ")."] data Field a@@ -136,7 +138,7 @@ let (withPositionalArguments, additionalArgumentsErrors) = fillInPositionalArguments arguments $ project options initialFieldStates- either Errors return additionalArgumentsErrors+ either errors return additionalArgumentsErrors to . SOP . Z <$> collectResult withPositionalArguments where@@ -146,7 +148,7 @@ reportGetOptErrors :: [String] -> Result () reportGetOptErrors parseErrors = case parseErrors of [] -> pure ()- errs -> Errors errs+ errs -> errors errs -- Creates a list of NS where every element corresponds to one field. To be -- used by 'getOpt'.@@ -191,7 +193,7 @@ then case cast (id :: FieldState x -> FieldState x) of (Just id' :: Maybe (FieldState [String] -> FieldState x)) -> Success $ id' PositionalArguments- Nothing -> Errors+ Nothing -> errors ["UseForPositionalArguments can only be used " ++ "for fields of type [String] not " ++ show (typeOf (impossible "mkInitialFieldStates" :: x))]@@ -211,12 +213,11 @@ case (\ (a, b, c) -> (sort a, b, c)) (getOpt Permute options args) of ([], _, _) -> return () -- no help or version flag given- (HelpFlag : _, _, _) -> OutputAndExit $- stripTrailingSpaces $+ (HelpFlag : _, _, _) -> outputAndExit $ usageInfo header $ toOptDescrUnit (mkOptDescrs modifiers fields) ++ toOptDescrUnit options- (VersionFlag version : _, _, _) -> OutputAndExit $+ (VersionFlag version : _, _, _) -> outputAndExit $ progName ++ " version " ++ version ++ "\n" where options :: [OptDescr OutputInfoFlag]@@ -248,11 +249,6 @@ positionalArgumentHelp (_ :* r) = positionalArgumentHelp r positionalArgumentHelp Nil = [] -stripTrailingSpaces :: String -> String-stripTrailingSpaces = unlines . map stripLines . lines- where- stripLines = reverse . dropWhile isSpace . reverse- -- Fills in the positional arguments in the NP that already contains the flag -- values. Fills in FieldErrors in case of -- - parse errors and@@ -298,8 +294,8 @@ inner :: FieldState x -> Result x inner s = case s of FieldSuccess v -> Success v- FieldErrors errs -> Errors errs- Unset err -> Errors [err]+ FieldErrors errs -> errors errs+ Unset err -> errors [err] PositionalArguments -> impossible "collectResult" PositionalArgument -> impossible "collectResult"
src/System/Console/GetOpt/Generics/Modifier.hs view
@@ -58,7 +58,7 @@ data Modifiers = Modifiers { _shortOptions :: [(String, [Char])], _renamings :: [(String, String)],- positionalArgumentsField :: Maybe (String, String),+ positionalArgumentsField :: [(String, String)], helpTexts :: [(String, String)], version :: Maybe String }@@ -68,7 +68,7 @@ mkModifiers = foldM inner empty where empty :: Modifiers- empty = Modifiers [] [] Nothing [] Nothing+ empty = Modifiers [] [] [] [] Nothing inner :: Modifiers -> Modifier -> Result Modifiers inner (Modifiers shorts renamings args help version) modifier = case modifier of@@ -82,7 +82,7 @@ return $ Modifiers shorts (insert fromNormalized to renamings) args help version (UseForPositionalArguments option typ) -> do normalized <- normalizeFieldName option- return $ Modifiers shorts renamings (Just (normalized, map toUpper typ)) help version+ return $ Modifiers shorts renamings ((normalized, map toUpper typ) : args) help version (AddOptionHelp option helpText) -> do normalized <- normalizeFieldName option return $ Modifiers shorts renamings args (insert normalized helpText help) version@@ -98,14 +98,14 @@ fromMaybe option (lookup option renamings) hasPositionalArgumentsField :: Modifiers -> Bool-hasPositionalArgumentsField = isJust . positionalArgumentsField+hasPositionalArgumentsField = not . null . positionalArgumentsField isPositionalArgumentsField :: Modifiers -> String -> Bool isPositionalArgumentsField modifiers field =- Just field == fmap fst (positionalArgumentsField modifiers)+ any (field ==) (map fst (positionalArgumentsField modifiers)) getPositionalArgumentType :: Modifiers -> Maybe String-getPositionalArgumentType = fmap snd . positionalArgumentsField+getPositionalArgumentType = fmap snd . listToMaybe . positionalArgumentsField getHelpText :: Modifiers -> String -> String getHelpText modifiers field = fromMaybe "" (lookup field (helpTexts modifiers))
src/System/Console/GetOpt/Generics/Result.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE DeriveFunctor #-} -module System.Console.GetOpt.Generics.Result where+module System.Console.GetOpt.Generics.Result (+ Result(..),+ errors,+ outputAndExit,+ handleResult,+ ) where import Prelude () import Prelude.Compat@@ -26,6 +31,12 @@ -- ^ The CLI was used with @--help@. The 'Result' contains the help message. deriving (Show, Eq, Ord, Functor) +errors :: [String] -> Result a+errors = Errors . map removeTrailingNewline++outputAndExit :: String -> Result a+outputAndExit = OutputAndExit . stripTrailingSpaces+ instance Applicative Result where pure = Success OutputAndExit message <*> _ = OutputAndExit message@@ -57,3 +68,16 @@ addNewlineIfMissing s | "\n" `isSuffixOf` s = s | otherwise = s ++ "\n"++removeTrailingNewline :: String -> String+removeTrailingNewline s+ | "\n" `isSuffixOf` s = init s+ | otherwise = s++stripTrailingSpaces :: String -> String+stripTrailingSpaces = reverse . inner . dropWhile (== ' ') . reverse+ where+ inner s = case s of+ ('\n' : ' ' : r) -> inner ('\n' : r)+ (a : r) -> a : inner r+ [] -> []
+ test/ModifiersSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}++module ModifiersSpec where++import Data.List+import Test.Hspec+import Test.Hspec.Expectations.Contrib++import System.Console.GetOpt.Generics+import System.Console.GetOpt.GenericsSpec+import Util++spec :: Spec+spec = do+ describe "AddShortOption" $ do+ it "allows modifiers for short options" $ do+ modsParse [AddShortOption "camel-case" 'x'] "-x foo"+ `shouldBe` Success (CamelCaseOptions "foo")++ it "allows modifiers in camelCase" $ do+ modsParse [AddShortOption "camelCase" 'x'] "-x foo"+ `shouldBe` Success (CamelCaseOptions "foo")++ let parse' :: String -> Result CamelCaseOptions+ parse' = modsParse [AddShortOption "camelCase" 'x']+ it "includes the short option in the help" $ do+ let OutputAndExit output = parse' "--help"+ output `shouldContain` "-x STRING"++ describe "RenameOption" $ do+ it "allows to rename options" $ do+ modsParse [RenameOption "camelCase" "bla"] "--bla foo"+ `shouldBe` Success (CamelCaseOptions "foo")++ let parse' = modsParse [RenameOption "camelCase" "foo", RenameOption "camelCase" "bar"]+ it "allows to shadow earlier modifiers with later modifiers" $ do+ parse' "--bar foo" `shouldBe` Success (CamelCaseOptions "foo")+ let Errors errs = parse' "--foo foo"+ show errs `shouldContain` "unknown argument: foo"++ it "contains renamed options in error messages" $ do+ let Errors errs = parse' []+ show errs `shouldNotContain` "camelCase"+ show errs `shouldContain` "camel-case"++ it "allows to address fields in Modifiers in slugified form" $ do+ modsParse [RenameOption "camel-case" "foo"] "--foo bar"+ `shouldBe` Success (CamelCaseOptions "bar")++ 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\n"++ it "--help takes precedence over --version" $ do+ let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version --help" :: Result Foo+ output `shouldSatisfy` ("show help and exit" `isInfixOf`)++ it "--version shows up in help output" $ do+ let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--help" :: Result Foo+ output `shouldSatisfy` ("show version and exit" `isInfixOf`)
+ test/ModifiersSpec/UseForPositionalArgumentsSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveGeneric #-}++module ModifiersSpec.UseForPositionalArgumentsSpec where++import Data.List+import qualified GHC.Generics as GHC+import Test.Hspec++import System.Console.GetOpt.Generics+import Util++data WithPositionalArguments+ = WithPositionalArguments {+ positionalArguments :: [String],+ someFlag :: Bool+ }+ deriving (GHC.Generic, Show, Eq)++instance Generic WithPositionalArguments+instance HasDatatypeInfo WithPositionalArguments++data WithMultiplePositionalArguments+ = WithMultiplePositionalArguments {+ positionalArgumentsA :: [String],+ positionalArgumentsB :: [String],+ someOtherFlag :: Bool+ }+ deriving (GHC.Generic, Show, Eq)++instance Generic WithMultiplePositionalArguments+instance HasDatatypeInfo WithMultiplePositionalArguments++spec :: Spec+spec = do+ it "allows positionalArguments" $ do+ modsParse+ [UseForPositionalArguments "positionalArguments" "type"]+ "foo bar --some-flag"+ `shouldBe` Success (WithPositionalArguments ["foo", "bar"] True)++ it "disallows to specify the option used for positional arguments" $ do+ modsParse+ [UseForPositionalArguments "positionalArguments" "type"]+ "--positional-arguments foo"+ `shouldBe`+ (Errors ["unrecognized option `--positional-arguments'"]+ :: Result WithPositionalArguments)++ it "complains about fields that don't have type [String]" $ do+ modsParse+ [UseForPositionalArguments "someFlag" "type"]+ "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 = modsParse+ [UseForPositionalArguments "positionalArguments" "foo"]+ "--help" :: Result WithPositionalArguments+ output `shouldSatisfy` ("prog-name [OPTIONS] [FOO]\n" `isPrefixOf`)++ it "complains about multiple PositionalArguments fields" $ do+ let modifiers =+ UseForPositionalArguments "positionalArgumentsA" "foo" :+ UseForPositionalArguments "positionalArgumentsB" "bar" :+ []+ (modsParse modifiers [] :: Result WithMultiplePositionalArguments)+ `shouldBe` Errors ["UseForPositionalArguments can only be used once"]
test/System/Console/GetOpt/Generics/ResultSpec.hs view
@@ -3,10 +3,12 @@ module System.Console.GetOpt.Generics.ResultSpec where import Control.Exception+import Data.List import System.Exit import System.IO import System.IO.Silently import Test.Hspec+import Test.QuickCheck hiding (Result(..)) import System.Console.GetOpt.Generics.Result @@ -18,6 +20,33 @@ (Errors ["foo"] >> Errors ["bar"] :: Result ()) `shouldBe` Errors ["foo", "bar"] + describe "errors" $ do+ it "removes trailing newlines" $ do+ (errors ["foo\n", "bar", "baz\n"] :: Result ()) `shouldBe`+ Errors ["foo", "bar", "baz"]++ describe "outputAndExit" $ do+ it "removes trailing spaces" $ do+ (outputAndExit "foo \nbar" :: Result ()) `shouldBe`+ OutputAndExit "foo\nbar"++ it "removes trailing spaces at the end" $ do+ (outputAndExit "foo " :: Result ()) `shouldBe`+ OutputAndExit "foo"++ it "quickcheck" $ do+ property $ \ s ->+ let OutputAndExit output = outputAndExit s+ in output `shouldSatisfy` (not . (" \n" `isInfixOf`))++ it "only strips spaces" $ do+ property $ \ s ->+ let OutputAndExit output = outputAndExit s+ in+ filter (/= ' ') output+ `shouldBe`+ filter (/= ' ') s+ describe "handleResult" $ do it "appends '\\n' at the end of error messages if missing" $ do output <- hCapture_ [stderr] $ do@@ -25,3 +54,13 @@ _ <- handleResult (Errors ["foo", "bar\n", "baz"]) return () output `shouldBe` "foo\nbar\nbaz\n"++ context "OutputAndExit" $ do+ it "throws ExitSuccess" $ do+ handleResult (OutputAndExit "foo")+ `shouldThrow` (== ExitSuccess)++ context "Errors" $ do+ it "throws an ExitFailure" $ do+ handleResult (Errors ["foo"])+ `shouldThrow` (== ExitFailure 1)
test/System/Console/GetOpt/GenericsSpec.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} module System.Console.GetOpt.GenericsSpec where@@ -7,20 +8,17 @@ import Prelude () import Prelude.Compat -import Control.Exception import Data.Foldable (forM_)-import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Data.List (isPrefixOf, isSuffixOf) import Data.Typeable 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+import Util spec :: Spec spec = do@@ -30,8 +28,6 @@ part4 part5 part6- part7- part8 data Foo = Foo {@@ -59,60 +55,41 @@ withArgs (words "--bar 4 --baz foo") $ getArguments `shouldReturn` Foo (Just 4) "foo" False + describe "parseArguments" $ do it "allows optional arguments" $ do- withArgs (words "--baz foo") $- getArguments `shouldReturn` Foo Nothing "foo" False+ parse "--baz foo" `shouldBe`+ Success (Foo Nothing "foo" False) it "allows boolean flags" $ do- withArgs (words "--bool --baz foo") $- getArguments `shouldReturn` Foo Nothing "foo" True+ parse "--bool --baz foo" `shouldBe`+ Success (Foo Nothing "foo" True) context "with invalid arguments" $ do- it "doesn't execute the action" $ do- let main = withArgs (words "--invalid") $ do- _ :: Foo <- getArguments- throwIO (ErrorCall "action")- main `shouldThrow` (== ExitFailure 1)- it "prints out an error" $ do- output <- hCapture_ [stderr] $ handle (\ (_ :: SomeException) -> return ()) $- withArgs (words "--no-such-option") $ do- _ :: Foo <- getArguments- return ()- output `shouldBe` "unrecognized option `--no-such-option'\nmissing option: --baz=STRING\n"+ let Errors messages = parse "--no-such-option" :: Result Foo+ messages `shouldBe`+ ["unrecognized option `--no-such-option'",+ "missing option: --baz=STRING"] 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 `shouldSatisfy` ("\n" `isSuffixOf`)+ let Errors [message] = parse [] :: Result Foo+ message `shouldBe` "missing option: --baz=STRING" 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 `shouldBe` "cannot parse as INTEGER (optional): foo\n"+ 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- (parseArguments "prog-name" [] (words "--baz foo unused") :: Result Foo)+ (parse "--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 `shouldBe` "cannot parse as INTEGER (optional): foo\n"+ 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- output <- capture_ $ withArgs ["--help"] $- handle (\ (_ :: SomeException) -> return ()) $ do- _ :: Foo <- getArguments- return ()+ let OutputAndExit output = parse "--help" :: Result Foo mapM_ (output `shouldContain`) $ "--bar=INTEGER" : "optional" : "--baz=STRING" :@@ -120,42 +97,26 @@ [] lines output `shouldSatisfy` (not . ("" `elem`)) - it "throws ExitSuccess" $ do- withArgs ["--help"] (getArguments :: IO Foo)- `shouldThrow` (== ExitSuccess)- it "contains help message about --help" $ do- output <- capture_ $ withArgs ["--help"] $- handle (\ (_ :: SomeException) -> return ()) $ do- _ :: Foo <- getArguments- return ()+ let OutputAndExit output = parse "--help" :: Result Foo output `shouldContain` "show help and exit" it "does not contain trailing spaces" $ do- output <- capture_ $ withArgs ["--help"] $- handle (\ (_ :: SomeException) -> return ()) $ do- _ :: Foo <- getArguments- return ()+ let OutputAndExit output = parse "--help" :: Result Foo forM_ (lines output) $ \ line -> line `shouldSatisfy` (not . (" " `isSuffixOf`)) - it "throws an exception when the options datatype is not allowed" $ do- output <- hCapture_ [stderr] $- withArgs ["--help"] $- handle (\ (_ :: SomeException) -> return ()) $ do- _ :: NotAllowed <- getArguments- return ()- output `shouldContain` "getopt-generics doesn't support sum types"- lines output `shouldSatisfy` (not . ("" `elem`))+ 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 =- parseArguments "prog-name" [] ["--help"] :: Result Foo+ let OutputAndExit output = parse "--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")+ parse "--baz one --baz two" `shouldBe` Success (Foo Nothing "two" False) data ListOptions@@ -169,18 +130,15 @@ part2 :: Spec part2 = do- describe "getArguments" $ do+ describe "parseArguments" $ do it "allows to interpret multiple uses of the same option as lists" $ do- withArgs (words "--multiple 23 --multiple 42") $ do- getArguments `shouldReturn` ListOptions [23, 42]+ parse "--multiple 23 --multiple 42"+ `shouldBe` Success (ListOptions [23, 42]) it "complains about invalid list arguments" $ do- output <- hCapture_ [stderr] $- withArgs (words "--multiple foo --multiple 13") $- handle (\ (_ :: SomeException) -> return ()) $ do- _ :: ListOptions <- getArguments- return ()- output `shouldBe` "cannot parse as INTEGER (multiple possible): foo\n"+ let Errors errs =+ parse "--multiple foo --multiple 13" :: Result ListOptions+ errs `shouldBe` ["cannot parse as INTEGER (multiple possible): foo"] data CamelCaseOptions = CamelCaseOptions {@@ -193,61 +151,22 @@ part3 :: Spec part3 = do- describe "getArguments" $ do+ describe "parseArguments" $ do it "turns camelCase selectors to lowercase and seperates with a dash" $ do- withArgs (words "--camel-case foo") $ do- getArguments `shouldReturn` CamelCaseOptions "foo"+ parse "--camel-case foo" `shouldBe` Success (CamelCaseOptions "foo") - describe "parseArguments" $ do it "help does not contain camelCase flags" $ do let OutputAndExit output :: Result CamelCaseOptions- = parseArguments "prog-name" [] ["--help"]+ = parse "--help" output `shouldNotContain` "camelCase" output `shouldContain` "camel-case" it "error messages don't contain camelCase flags" $ do let Errors errs :: Result CamelCaseOptions- = parseArguments "prog-name" [] ["--bla"]+ = parse "--bla" show errs `shouldNotContain` "camelCase" show errs `shouldContain` "camel-case" - context "AddShortOption" $ do- it "allows modifiers for short options" $ do- parseArguments "prog-name" [AddShortOption "camel-case" 'x'] (words "-x foo")- `shouldBe` Success (CamelCaseOptions "foo")-- it "allows modifiers in camelCase" $ do- parseArguments "prog-name" [AddShortOption "camelCase" 'x'] (words "-x foo")- `shouldBe` Success (CamelCaseOptions "foo")-- let parse :: [String] -> Result CamelCaseOptions- 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"-- context "RenameOption" $ do- it "allows to rename options" $ do- parseArguments "prog-name" [RenameOption "camelCase" "bla"] (words "--bla foo")- `shouldBe` Success (CamelCaseOptions "foo")-- 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")- `shouldBe` Success (CamelCaseOptions "foo")- let Errors errs = parse (words "--foo foo")- show errs `shouldContain` "unknown argument: foo"-- it "contains renamed options in error messages" $ do- let Errors errs = parse []- show errs `shouldNotContain` "camelCase"- show errs `shouldContain` "camel-case"-- it "allows to address fields in Modifiers in slugified form" $ do- parseArguments "prog-name" [RenameOption "camel-case" "foo"] (words "--foo bar")- `shouldBe` Success (CamelCaseOptions "bar")- data WithUnderscore = WithUnderscore { _withUnderscore :: String@@ -261,70 +180,9 @@ part4 = do describe "parseArguments" $ do it "ignores leading underscores in field names" $ do- parseArguments "prog-name" [] (words "--with-underscore foo")+ parse "--with-underscore foo" `shouldBe` Success (WithUnderscore "foo") -data WithPositionalArguments- = WithPositionalArguments {- positionalArguments :: [String],- someFlag :: Bool- }- deriving (GHC.Generic, Show, Eq)--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 "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 "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 "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,@@ -350,15 +208,13 @@ "baz" -> Just CBaz _ -> Nothing -part6 :: Spec-part6 = do+part5 :: Spec+part5 = do describe "parseArguments" $ do context "CustomFields" $ do it "allows easy implementation of custom field types" $ do- parseArguments "prog-name" []- (words "--custom foo --custom-list bar --custom-maybe baz")- `shouldBe`- Success (CustomFields CFoo [CBar] (Just CBaz))+ parse "--custom foo --custom-list bar --custom-maybe baz"+ `shouldBe` Success (CustomFields CFoo [CBar] (Just CBaz)) data WithoutSelectors = WithoutSelectors String Bool Int@@ -367,31 +223,31 @@ instance Generic WithoutSelectors instance HasDatatypeInfo WithoutSelectors -part7 :: Spec-part7 = do+part6 :: Spec+part6 = do describe "parseArguments" $ do context "WithoutSelectors" $ do it "populates fields without selectors from positional arguments" $ do- parseArguments "prog-name" [] (words "foo true 23")+ parse "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+ 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- (parseArguments "prog-name" [] (words "foo") :: Result WithoutSelectors)+ (parse "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)+ (parse "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))+ (parse "42 bar" :: Result (Int, String)) `shouldBe` Success (42, "bar") describe "Option.Bool" $ do@@ -433,19 +289,3 @@ it "renders as NUMBER in help and error output" $ do argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER"--part8 :: Spec-part8 = do- describe "parseArgument" $ do- context "--version" $ do- it "implements --version" $ do- let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--version") :: Result Foo- output `shouldBe` "foo version 1.0.0\n"-- it "--help takes precedence over --version" $ do- let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--version --help") :: Result Foo- output `shouldSatisfy` ("show help and exit" `isInfixOf`)-- it "--version shows up in help output" $ do- let OutputAndExit output = parseArguments "foo" [AddVersionFlag "1.0.0"] (words "--help") :: Result Foo- output `shouldSatisfy` ("show version and exit" `isInfixOf`)
+ test/Util.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE ConstraintKinds #-}++module Util where++import System.Console.GetOpt.Generics++parse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+ String -> Result a+parse = modsParse []++modsParse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) =>+ [Modifier] -> String -> Result a+modsParse modifiers = parseArguments "prog-name" modifiers . words