{-# 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`)