getopt-generics-0.7.1: test/System/Console/GetOpt/GenericsSpec.hs
{-# 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 (isInfixOf, 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
spec :: Spec
spec = do
part1
part2
part3
part4
part5
part6
part7
part8
data Foo
= Foo {
bar :: Maybe Int,
baz :: String,
bool :: Bool
}
deriving (GHC.Generic, Show, Eq)
instance Generic Foo
instance HasDatatypeInfo Foo
data NotAllowed
= NotAllowed1
| NotAllowed2
deriving (GHC.Generic, Show, Eq)
instance Generic NotAllowed
instance HasDatatypeInfo NotAllowed
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
it "allows optional arguments" $ do
withArgs (words "--baz foo") $
getArguments `shouldReturn` Foo Nothing "foo" False
it "allows boolean flags" $ do
withArgs (words "--bool --baz foo") $
getArguments `shouldReturn` 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"
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`)
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"
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 `shouldBe` "cannot parse as INTEGER (optional): foo\n"
context "--help" $ do
it "implements --help" $ do
output <- capture_ $ withArgs ["--help"] $
handle (\ (_ :: SomeException) -> return ()) $ do
_ :: Foo <- getArguments
return ()
mapM_ (output `shouldContain`) $
"--bar=INTEGER" : "optional" :
"--baz=STRING" :
"--bool" :
[]
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 ()
output `shouldContain` "show help and exit"
it "does not contain trailing spaces" $ do
output <- capture_ $ withArgs ["--help"] $
handle (\ (_ :: SomeException) -> return ()) $ do
_ :: Foo <- getArguments
return ()
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 "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")
`shouldBe` Success (Foo Nothing "two" False)
data ListOptions
= ListOptions {
multiple :: [Int]
}
deriving (GHC.Generic, Show, Eq)
instance Generic ListOptions
instance HasDatatypeInfo ListOptions
part2 :: Spec
part2 = do
describe "getArguments" $ 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]
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"
data CamelCaseOptions
= CamelCaseOptions {
camelCase :: String
}
deriving (GHC.Generic, Show, Eq)
instance Generic CamelCaseOptions
instance HasDatatypeInfo CamelCaseOptions
part3 :: Spec
part3 = do
describe "getArguments" $ do
it "turns camelCase selectors to lowercase and seperates with a dash" $ do
withArgs (words "--camel-case foo") $ do
getArguments `shouldReturn` CamelCaseOptions "foo"
describe "parseArguments" $ do
it "help does not contain camelCase flags" $ do
let OutputAndExit output :: Result CamelCaseOptions
= 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 "prog-name" [] ["--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
}
deriving (GHC.Generic, Show, Eq)
instance Generic WithUnderscore
instance HasDatatypeInfo WithUnderscore
part4 :: Spec
part4 = do
describe "parseArguments" $ do
it "ignores leading underscores in field names" $ do
parseArguments "prog-name" [] (words "--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,
customList :: [Custom],
customMaybe :: Maybe Custom
}
deriving (GHC.Generic, Show, Eq)
instance Generic CustomFields
instance HasDatatypeInfo CustomFields
data Custom
= CFoo
| CBar
| CBaz
deriving (Show, Eq, Typeable)
instance Option Custom where
argumentType Proxy = "custom"
parseArgument x = case x of
"foo" -> Just CFoo
"bar" -> Just CBar
"baz" -> Just CBaz
_ -> Nothing
part6 :: Spec
part6 = 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))
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"
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`)