{-# LANGUAGE CPP, DataKinds, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-}

module Main
    ( main
    ) where

import Control.Applicative (Const)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.HashMap.Strict as HM
import Data.Int
import Data.Scientific (Scientific)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Vector as V
import qualified Data.Foldable as F
import Data.List (isPrefixOf)
import Data.Word
import Numeric.Natural
import GHC.Generics (Generic)
import Test.HUnit
import Test.Framework as TF
import Test.Framework.Providers.HUnit as TF
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import Test.Framework.Providers.QuickCheck2 as TF

import Data.Csv hiding (record)
import qualified Data.Csv.Streaming as S

------------------------------------------------------------------------
-- Parse tests

decodesAs :: BL.ByteString -> [[B.ByteString]] -> Assertion
decodesAs input expected = assertResult input expected $ decode NoHeader input

decodesWithAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]] -> Assertion
decodesWithAs opts input expected =
    assertResult input expected $ decodeWith opts NoHeader input

assertResult :: BL.ByteString -> [[B.ByteString]]
             -> Either String (V.Vector (V.Vector B.ByteString)) -> Assertion
assertResult input expected res = case res of
    Right r  -> V.fromList (map V.fromList expected) @=? r
    Left err -> assertFailure $
                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
                "parse error: " ++ err

decodeFailsWith :: BL.ByteString -> String -> Assertion
decodeFailsWith input expected = case decode NoHeader input of
    Right r  -> assertFailure $ "input: " ++ show (BL8.unpack input) ++ "\n" ++
                "retuned: " ++ show (r :: (V.Vector (V.Vector B.ByteString))) ++ "\n" ++
                "whereas should have failed with " <> expected
    Left err -> assertBool ("got " <> err <> "\ninstead of " <> expected)
                $ ("parse error ("++expected++")") `isPrefixOf` err

encodesAs :: [[B.ByteString]] -> BL.ByteString -> Assertion
encodesAs input expected =
    encode (map V.fromList input) @?= expected

encodesWithAs :: EncodeOptions -> [[B.ByteString]] -> BL.ByteString -> Assertion
encodesWithAs opts input expected =
    encodeWith opts (map V.fromList input) @?= expected

namedEncodesAs :: [B.ByteString] -> [[(B.ByteString, B.ByteString)]]
               -> BL.ByteString -> Assertion
namedEncodesAs hdr input expected =
    encodeByName (V.fromList hdr) (map HM.fromList input) @?= expected

namedEncodesWithAs :: EncodeOptions -> [B.ByteString]
                   -> [[(B.ByteString, B.ByteString)]]
                   -> BL.ByteString -> Assertion
namedEncodesWithAs opts hdr input expected =
    encodeByNameWith opts (V.fromList hdr) (map HM.fromList input) @?= expected

namedDecodesAs :: BL.ByteString -> [B.ByteString]
               -> [[(B.ByteString, B.ByteString)]] -> Assertion
namedDecodesAs input ehdr expected = case decodeByName input of
    Right r  -> (V.fromList ehdr, expected') @=? r
    Left err -> assertFailure $
                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
                "parse error: " ++ err
  where
    expected' = V.fromList $ map HM.fromList expected

recordsToList :: S.Records a -> Either String [a]
recordsToList (S.Nil (Just err) _)  = Left err
recordsToList (S.Nil Nothing _)     = Right []
recordsToList (S.Cons (Left err) _) = Left err
recordsToList (S.Cons (Right x) rs) = case recordsToList rs of
    l@(Left _) -> l
    (Right xs) -> Right (x : xs)

decodesStreamingAs :: BL.ByteString -> [[B.ByteString]] -> Assertion
decodesStreamingAs input expected =
    assertResult input expected $ fmap (V.fromList . map V.fromList) $
    recordsToList $ S.decode NoHeader input

decodesWithStreamingAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]]
                       -> Assertion
decodesWithStreamingAs opts input expected =
    assertResult input expected $ fmap (V.fromList . map V.fromList) $
    recordsToList $ S.decodeWith opts NoHeader input

namedDecodesStreamingAs :: BL.ByteString -> [B.ByteString]
                        -> [[(B.ByteString, B.ByteString)]] -> Assertion
namedDecodesStreamingAs input ehdr expected = case S.decodeByName input of
    Right (hdr, rs) -> case recordsToList rs of
        Right xs -> (V.fromList ehdr, expected') @=? (hdr, xs)
        Left err -> assertFailure $
                    "           input: " ++ show (BL8.unpack input) ++ "\n" ++
                    "conversion error: " ++ err
    Left err -> assertFailure $
                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
                "parse error: " ++ err
  where
    expected' = map HM.fromList expected

positionalTests :: [TF.Test]
positionalTests =
    [ testGroup "encode" $ map encodeTest
      [ ("simple",       [["abc"]],          "abc\r\n")
      , ("quoted",       [["\"abc\""]],      "\"\"\"abc\"\"\"\r\n")
      , ("quote",        [["a\"b"]],         "\"a\"\"b\"\r\n")
      , ("quotedQuote",  [["\"a\"b\""]],     "\"\"\"a\"\"b\"\"\"\r\n")
      , ("leadingSpace", [[" abc"]],         " abc\r\n")
      , ("comma",        [["abc,def"]],      "\"abc,def\"\r\n")
      , ("twoFields",    [["abc","def"]],    "abc,def\r\n")
      , ("twoRecords",   [["abc"], ["def"]], "abc\r\ndef\r\n")
      , ("newline",      [["abc\ndef"]],     "\"abc\ndef\"\r\n")
      ]
    , testGroup "encode" $ map encodeTestUnqtd
      [ ("simple",       [["abc"]],          "abc\r\n")
      , ("quoted",       [["\"abc\""]],      "\"abc\"\r\n")
      , ("quote",        [["a\"b"]],         "a\"b\r\n")
      , ("quotedQuote",  [["\"a\"b\""]],     "\"a\"b\"\r\n")
      , ("leadingSpace", [[" abc"]],         " abc\r\n")
      , ("comma",        [["abc,def"]],      "abc,def\r\n")
      , ("twoFields",    [["abc","def"]],    "abc,def\r\n")
      , ("twoRecords",   [["abc"], ["def"]], "abc\r\ndef\r\n")
      , ("newline",      [["abc\ndef"]],     "abc\ndef\r\n")
      ]
    , testGroup "encode" $ map encodeTestAllqtd
      [ ("simple",       [["abc"]],          "\"abc\"\r\n")
      , ("quoted",       [["\"abc\""]],      "\"\"\"abc\"\"\"\r\n")
      , ("quote",        [["a\"b"]],         "\"a\"\"b\"\r\n")
      , ("quotedQuote",  [["\"a\"b\""]],     "\"\"\"a\"\"b\"\"\"\r\n")
      , ("leadingSpace", [[" abc"]],         "\" abc\"\r\n")
      , ("comma",        [["abc,def"]],      "\"abc,def\"\r\n")
      , ("twoFields",    [["abc","def"]],    "\"abc\",\"def\"\r\n")
      , ("twoRecords",   [["abc"], ["def"]], "\"abc\"\r\n\"def\"\r\n")
      , ("newline",      [["abc\ndef"]],     "\"abc\ndef\"\r\n")
      ]

    , testGroup "encodeWith"
      [ testCase "tab-delim" $ encodesWithAs (defEnc { encDelimiter = 9 })
        [["1", "2"]] "1\t2\r\n"
      , testCase "newline" $ encodesWithAs (defEnc {encUseCrLf = False})
        [["1", "2"], ["3", "4"]] "1,2\n3,4\n"
      ]
    , testGroup "decode" $ map decodeTest decodeTests
    , testGroup "decodeWith" $ map decodeWithTest decodeWithTests
    , testGroup "streaming"
      [ testGroup "decode" $ map streamingDecodeTest decodeTests
      , testGroup "decodeWith" $ map streamingDecodeWithTest decodeWithTests
      ]
    , testGroup "failing"
      [ testCase "escapedMalformed0" $
          "baz,\"" `decodeFailsWith` "Failed reading: trailing double quote"
      ]

    ]
  where
    rfc4180Input = BL8.pack $
                   "#field1,field2,field3\n" ++
                   "\"aaa\",\"bb\n" ++
                   "b\",\"ccc\"\n" ++
                   "\"a,a\",\"b\"\"bb\",\"ccc\"\n" ++
                   "zzz,yyy,xxx\n"
    rfc4180Output = [["#field1", "field2", "field3"],
                     ["aaa", "bb\nb", "ccc"],
                     ["a,a", "b\"bb", "ccc"],
                     ["zzz", "yyy", "xxx"]]
    decodeTests =
        [ ("simple",       "a,b,c\n",        [["a", "b", "c"]])
        , ("crlf",         "a,b\r\nc,d\r\n", [["a", "b"], ["c", "d"]])
        , ("noEol",        "a,b,c",          [["a", "b", "c"]])
        , ("blankLine",    "a,b,c\n\nd,e,f\n\n",
           [["a", "b", "c"], ["d", "e", "f"]])
        , ("leadingSpace", " a,  b,   c\n",  [[" a", "  b", "   c"]])
        , ("rfc4180", rfc4180Input, rfc4180Output)
        , ("escapedDoubleQuotes"
          , "\"x,y\",z\nbaz,\"bar\nfoo,\""
          , [["x,y", "z"], ["baz", "bar\nfoo,"]]
          )
        ]
    decodeWithTests =
        [ ("tab-delim", defDec { decDelimiter = 9 }, "1\t2", [["1", "2"]])
        ]

    encodeTest (name, input, expected) =
        testCase name $ input `encodesAs` expected
    encodeTestUnqtd (name, input, expected) =
        testCase name $ encodesWithAs defEncNoneEnq input expected
    encodeTestAllqtd (name, input, expected) =
        testCase name $ encodesWithAs defEncAllEnq input expected
    decodeTest (name, input, expected) =
        testCase name $ input `decodesAs` expected
    decodeWithTest (name, opts, input, expected) =
        testCase name $ decodesWithAs opts input expected
    streamingDecodeTest (name, input, expected) =
        testCase name $ input `decodesStreamingAs` expected
    streamingDecodeWithTest (name, opts, input, expected) =
        testCase name $ decodesWithStreamingAs opts input expected
    defEnc = defaultEncodeOptions
    defEncNoneEnq = defaultEncodeOptions { encQuoting = QuoteNone }
    defEncAllEnq  = defaultEncodeOptions { encQuoting = QuoteAll  }
    defDec = defaultDecodeOptions

nameBasedTests :: [TF.Test]
nameBasedTests =
    [ testGroup "encode" $ map encodeTest
      [ ("simple", ["field"], [[("field", "abc")]], "field\r\nabc\r\n")
      , ("twoFields", ["field1", "field2"],
         [[("field1", "abc"), ("field2", "def")]],
         "field1,field2\r\nabc,def\r\n")
      , ("twoRecords", ["field"], [[("field", "abc")], [("field", "def")]],
         "field\r\nabc\r\ndef\r\n")
      ]
    , testGroup "encodeWith" $ map encodeWithTest
      [ ("no header", defEnc {encIncludeHeader = False}, ["field"],
         [[("field", "abc")]], "abc\r\n")
      ]
    , testGroup "decode" $ map decodeTest decodeTests
    , testGroup "streaming"
      [ testGroup "decode" $ map streamingDecodeTest decodeTests
      ]
    ]
  where
    decodeTests =
        [ ("simple", "field\r\nabc\r\n", ["field"], [[("field", "abc")]])
        , ("twoFields", "field1,field2\r\nabc,def\r\n", ["field1", "field2"],
           [[("field1", "abc"), ("field2", "def")]])
        , ("twoRecords", "field\r\nabc\r\ndef\r\n", ["field"],
           [[("field", "abc")], [("field", "def")]])
        , ("cr header", "field\rabc", ["field"], [[("field", "abc")]])
        , ("cr trailing", "field\rabc\r", ["field"], [[("field", "abc")]])
        , ("cr separator", "field\rabc\rdef", ["field"], [[("field", "abc")],[("field","def")]])
        ]

    encodeTest (name, hdr, input, expected) =
        testCase name $ namedEncodesAs hdr input expected
    encodeWithTest (name, opts, hdr, input, expected) =
        testCase name $ namedEncodesWithAs opts hdr input expected
    decodeTest (name, input, hdr, expected) =
        testCase name $ namedDecodesAs input hdr expected
    streamingDecodeTest (name, input, hdr, expected) =
        testCase name $ namedDecodesStreamingAs input hdr expected
    defEnc = defaultEncodeOptions

------------------------------------------------------------------------
-- Conversion tests

-- A single column with an empty string is indistinguishable from an
-- empty line (which we will ignore.) We therefore encode at least two
-- columns.
roundTrip :: (Eq a, FromField a, ToField a) => a -> Bool
roundTrip x = Right (V.fromList record) == decode NoHeader (encode record)
  where record = [(x, dummy)]
        dummy = 'a'

roundTripUnicode :: T.Text -> Assertion
roundTripUnicode x = Right (V.fromList record) @=?
                     decode NoHeader (encode record)
  where record = [(x, dummy)]
        dummy = 'a'

boundary :: forall a. (Bounded a, Eq a, FromField a, ToField a) => a -> Bool
boundary _dummy = roundTrip (minBound :: a) && roundTrip (maxBound :: a)

partialDecode :: Parser a -> Assertion
partialDecode p = case runParser p of
  Left _  -> return ()
  Right _ -> assertFailure "expected partial field decode"

expect :: (Eq a, Show a) => Parser a -> a -> Assertion
expect p a0 =
  case runParser p of
    Right a -> a @=? a0
    Left  e -> assertFailure e

conversionTests :: [TF.Test]
conversionTests =
    [ testGroup "roundTrip"
      [ testProperty "Char" (roundTrip :: Char -> Bool)
      , testProperty "ByteString" (roundTrip :: B.ByteString -> Bool)
      , testProperty "Int" (roundTrip :: Int -> Bool)
      , testProperty "Integer" (roundTrip :: Integer -> Bool)
      , testProperty "Int8" (roundTrip :: Int8 -> Bool)
      , testProperty "Int16" (roundTrip :: Int16 -> Bool)
      , testProperty "Int32" (roundTrip :: Int32 -> Bool)
      , testProperty "Int64" (roundTrip :: Int64 -> Bool)
      , testProperty "Natural" (roundTrip :: Natural -> Bool)
      , testProperty "Word" (roundTrip :: Word -> Bool)
      , testProperty "Word8" (roundTrip :: Word8 -> Bool)
      , testProperty "Word16" (roundTrip :: Word16 -> Bool)
      , testProperty "Word32" (roundTrip :: Word32 -> Bool)
      , testProperty "Word64" (roundTrip :: Word64 -> Bool)
      , testProperty "Scientific" (roundTrip :: Scientific -> Bool)
      , testProperty "lazy ByteString"
        (roundTrip :: BL.ByteString -> Bool)
      , testProperty "Text" (roundTrip :: T.Text -> Bool)
      , testProperty "lazy Text" (roundTrip :: LT.Text -> Bool)
      -- Using DataKinds here to prove that our Const instance is polykinded.
      , testProperty "Const Char" (roundTrip :: Const Char "" -> Bool)
      ]
    , testGroup "boundary"
      [ testProperty "Int" (boundary (undefined :: Int))
      , testProperty "Int8" (boundary (undefined :: Int8))
      , testProperty "Int16" (boundary (undefined :: Int16))
      , testProperty "Int32" (boundary (undefined :: Int32))
      , testProperty "Int64" (boundary (undefined :: Int64))
      , testProperty "Word" (boundary (undefined :: Word))
      , testProperty "Word8" (boundary (undefined :: Word8))
      , testProperty "Word16" (boundary (undefined :: Word16))
      , testProperty "Word32" (boundary (undefined :: Word32))
      , testProperty "Word64" (boundary (undefined :: Word64))
      ]
    , testGroup "Unicode"
      [ testCase "Chinese" (roundTripUnicode "我能吞下玻璃而不伤身体。")
      , testCase "Icelandic" (roundTripUnicode
                              "Sævör grét áðan því úlpan var ónýt.")
      , testCase "Turkish" (roundTripUnicode
                            "Cam yiyebilirim, bana zararı dokunmaz.")
      ]
    , testGroup "Partial Decodes"
      [ testCase "Int"         (partialDecode
                                (parseField "12.7" :: Parser Int))
      , testCase "Natural"     (partialDecode
                                (parseField "12.7" :: Parser Natural))
      , testCase "Word"        (partialDecode
                                (parseField "12.7" :: Parser Word))
      , testCase "Scientific"  (partialDecode
                                (parseField "1.0+" :: Parser Scientific))
      , testCase "Double"      (partialDecode
                                (parseField "1.0+" :: Parser Double))
      , testCase "Integer"     (partialDecode
                                (parseField "1e6"  :: Parser Integer))
      ]
    , testGroup "Space trimming"
      [ testCase "_Int"         (expect (parseField " 12"     :: Parser Int)        12)
      , testCase "Int_"         (expect (parseField "12 "     :: Parser Int)        12)
      , testCase "_Int_"        (expect (parseField " 12 "    :: Parser Int)        12)
      , testCase "_Natural"     (expect (parseField " 12"     :: Parser Natural)    12)
      , testCase "Natural_"     (expect (parseField "12 "     :: Parser Natural)    12)
      , testCase "_Natural_"    (expect (parseField " 12 "    :: Parser Natural)    12)
      , testCase "_Word"        (expect (parseField " 12"     :: Parser Word)       12)
      , testCase "Word_"        (expect (parseField "12 "     :: Parser Word)       12)
      , testCase "_Word_"       (expect (parseField " 12 "    :: Parser Word)       12)
      , testCase "_Scientific"  (expect (parseField " 1.2e1"  :: Parser Scientific) 12)
      , testCase "Scientific_"  (expect (parseField "1.2e1 "  :: Parser Scientific) 12)
      , testCase "_Scientific_" (expect (parseField " 1.2e1 " :: Parser Scientific) 12)
      , testCase "_Double"      (expect (parseField " 1.2e1"  :: Parser Double)     12)
      , testCase "Double_"      (expect (parseField "1.2e1 "  :: Parser Double)     12)
      , testCase "_Double_"     (expect (parseField " 1.2e1 " :: Parser Double)     12)
      ]
    ]

------------------------------------------------------------------------
-- Custom options tests

customDelim :: Word8 -> B.ByteString -> B.ByteString -> Property
customDelim delim f1 f2 = delim `notElem` [cr, nl, dquote] ==>
    (decodeWith decOpts NoHeader (encodeWith encOpts [V.fromList [f1, f2]]) ==
     Right (V.fromList [V.fromList [f1, f2]]))
  where
    encOpts = defaultEncodeOptions { encDelimiter = delim }
    decOpts = defaultDecodeOptions { decDelimiter = delim }
    nl = 10
    cr = 13
    dquote = 34

customOptionsTests :: [TF.Test]
customOptionsTests =
    [ testProperty "customDelim" customDelim
    ]

------------------------------------------------------------------------
-- Instance tests

instanceTests :: [TF.Test]
instanceTests =
  [
    testGroup "Records instances"
    [ testCase "foldr Foldable" (expected @=? F.foldr (:) [] input)
    , testCase "foldl' Foldable" (expected @=? F.foldl' (flip (:)) [] input)
    ]
  ]
  where
    input = S.Cons (Left "empty") (
      S.Cons (Right ("a" :: String)) (S.Nil Nothing BL8.empty))
    expected = ["a" :: String]

------------------------------------------------------------------------
-- Custom conversion option tests

genericConversionTests :: [TF.Test]
genericConversionTests =
    [ testCase "headerOrder" (header ["column1", "column2", "column_3"] @=? hdrs)
    , testCase "encode" (encodeDefaultOrderedByName sampleValues @?= sampleEncoding)
    , testCase "decode" (Right (hdrs, V.fromList sampleValues) @=? decodeByName sampleEncoding)
    , testProperty "roundTrip" rtProp
    ]
  where
    hdrs = headerOrder (undefined :: SampleType)

    sampleValues = [ SampleType ""      1     Nothing
                   , SampleType "field" 99999 (Just 1.234)
                   ]

    sampleEncoding = "column1,column2,column_3\r\n,1,\r\nfield,99999,1.234\r\n"

    rtProp :: [SampleType] -> Bool
    rtProp vs = Right (hdrs, V.fromList vs)
                == decodeByName (encodeDefaultOrderedByName vs)

data SampleType = SampleType
  { _column1  :: !T.Text
  , column2   :: !Int
  , _column_3 :: !(Maybe Double)
  } deriving (Eq, Show, Read, Generic)

sampleOptions :: Options
sampleOptions = defaultOptions { fieldLabelModifier = rmUnderscore }
  where
    rmUnderscore ('_':str) = str
    rmUnderscore str       = str

instance ToNamedRecord SampleType where
  toNamedRecord = genericToNamedRecord sampleOptions

instance FromNamedRecord SampleType where
  parseNamedRecord = genericParseNamedRecord sampleOptions

instance DefaultOrdered SampleType where
  headerOrder = genericHeaderOrder sampleOptions

instance Arbitrary SampleType where
  arbitrary = SampleType <$> arbitrary <*> arbitrary <*> arbitrary

------------------------------------------------------------------------
-- Test harness

allTests :: [TF.Test]
allTests = [ testGroup "positional" positionalTests
           , testGroup "named" nameBasedTests
           , testGroup "conversion" conversionTests
           , testGroup "custom-options" customOptionsTests
           , testGroup "instances" instanceTests
           , testGroup "generic-conversions" genericConversionTests
           ]

main :: IO ()
main = defaultMain allTests