1{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}
2
3#if __GLASGOW_HASKELL__ >= 801
4{-# OPTIONS_GHC -Wno-orphans -Wno-unused-top-binds #-}
5#else
6{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-binds #-}
7#endif
8
9module Main
10    ( main
11    ) where
12
13import qualified Data.ByteString as B
14import qualified Data.ByteString.Lazy as BL
15import qualified Data.ByteString.Lazy.Char8 as BL8
16import qualified Data.HashMap.Strict as HM
17import Data.Int
18import Data.Scientific (Scientific)
19import qualified Data.Text as T
20import qualified Data.Text.Lazy as LT
21import qualified Data.Vector as V
22import qualified Data.Foldable as F
23import Data.Word
24import Numeric.Natural
25import GHC.Generics (Generic)
26import Test.HUnit
27import Test.Framework as TF
28import Test.Framework.Providers.HUnit as TF
29import Test.QuickCheck
30import Test.QuickCheck.Instances ()
31import Test.Framework.Providers.QuickCheck2 as TF
32
33import Data.Csv hiding (record)
34import qualified Data.Csv.Streaming as S
35
36#if !MIN_VERSION_base(4,8,0)
37import Control.Applicative ((<$>), (<*>))
38#endif
39
40------------------------------------------------------------------------
41-- Parse tests
42
43decodesAs :: BL.ByteString -> [[B.ByteString]] -> Assertion
44decodesAs input expected = assertResult input expected $ decode NoHeader input
45
46decodesWithAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]] -> Assertion
47decodesWithAs opts input expected =
48    assertResult input expected $ decodeWith opts NoHeader input
49
50assertResult :: BL.ByteString -> [[B.ByteString]]
51             -> Either String (V.Vector (V.Vector B.ByteString)) -> Assertion
52assertResult input expected res = case res of
53    Right r  -> V.fromList (map V.fromList expected) @=? r
54    Left err -> assertFailure $
55                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
56                "parse error: " ++ err
57
58encodesAs :: [[B.ByteString]] -> BL.ByteString -> Assertion
59encodesAs input expected =
60    encode (map V.fromList input) @?= expected
61
62encodesWithAs :: EncodeOptions -> [[B.ByteString]] -> BL.ByteString -> Assertion
63encodesWithAs opts input expected =
64    encodeWith opts (map V.fromList input) @?= expected
65
66namedEncodesAs :: [B.ByteString] -> [[(B.ByteString, B.ByteString)]]
67               -> BL.ByteString -> Assertion
68namedEncodesAs hdr input expected =
69    encodeByName (V.fromList hdr) (map HM.fromList input) @?= expected
70
71namedEncodesWithAs :: EncodeOptions -> [B.ByteString]
72                   -> [[(B.ByteString, B.ByteString)]]
73                   -> BL.ByteString -> Assertion
74namedEncodesWithAs opts hdr input expected =
75    encodeByNameWith opts (V.fromList hdr) (map HM.fromList input) @?= expected
76
77namedDecodesAs :: BL.ByteString -> [B.ByteString]
78               -> [[(B.ByteString, B.ByteString)]] -> Assertion
79namedDecodesAs input ehdr expected = case decodeByName input of
80    Right r  -> (V.fromList ehdr, expected') @=? r
81    Left err -> assertFailure $
82                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
83                "parse error: " ++ err
84  where
85    expected' = V.fromList $ map HM.fromList expected
86
87recordsToList :: S.Records a -> Either String [a]
88recordsToList (S.Nil (Just err) _)  = Left err
89recordsToList (S.Nil Nothing _)     = Right []
90recordsToList (S.Cons (Left err) _) = Left err
91recordsToList (S.Cons (Right x) rs) = case recordsToList rs of
92    l@(Left _) -> l
93    (Right xs) -> Right (x : xs)
94
95decodesStreamingAs :: BL.ByteString -> [[B.ByteString]] -> Assertion
96decodesStreamingAs input expected =
97    assertResult input expected $ fmap (V.fromList . map V.fromList) $
98    recordsToList $ S.decode NoHeader input
99
100decodesWithStreamingAs :: DecodeOptions -> BL.ByteString -> [[B.ByteString]]
101                       -> Assertion
102decodesWithStreamingAs opts input expected =
103    assertResult input expected $ fmap (V.fromList . map V.fromList) $
104    recordsToList $ S.decodeWith opts NoHeader input
105
106namedDecodesStreamingAs :: BL.ByteString -> [B.ByteString]
107                        -> [[(B.ByteString, B.ByteString)]] -> Assertion
108namedDecodesStreamingAs input ehdr expected = case S.decodeByName input of
109    Right (hdr, rs) -> case recordsToList rs of
110        Right xs -> (V.fromList ehdr, expected') @=? (hdr, xs)
111        Left err -> assertFailure $
112                    "           input: " ++ show (BL8.unpack input) ++ "\n" ++
113                    "conversion error: " ++ err
114    Left err -> assertFailure $
115                "      input: " ++ show (BL8.unpack input) ++ "\n" ++
116                "parse error: " ++ err
117  where
118    expected' = map HM.fromList expected
119
120positionalTests :: [TF.Test]
121positionalTests =
122    [ testGroup "encode" $ map encodeTest
123      [ ("simple",       [["abc"]],          "abc\r\n")
124      , ("quoted",       [["\"abc\""]],      "\"\"\"abc\"\"\"\r\n")
125      , ("quote",        [["a\"b"]],         "\"a\"\"b\"\r\n")
126      , ("quotedQuote",  [["\"a\"b\""]],     "\"\"\"a\"\"b\"\"\"\r\n")
127      , ("leadingSpace", [[" abc"]],         " abc\r\n")
128      , ("comma",        [["abc,def"]],      "\"abc,def\"\r\n")
129      , ("twoFields",    [["abc","def"]],    "abc,def\r\n")
130      , ("twoRecords",   [["abc"], ["def"]], "abc\r\ndef\r\n")
131      , ("newline",      [["abc\ndef"]],     "\"abc\ndef\"\r\n")
132      ]
133    , testGroup "encode" $ map encodeTestUnqtd
134      [ ("simple",       [["abc"]],          "abc\r\n")
135      , ("quoted",       [["\"abc\""]],      "\"abc\"\r\n")
136      , ("quote",        [["a\"b"]],         "a\"b\r\n")
137      , ("quotedQuote",  [["\"a\"b\""]],     "\"a\"b\"\r\n")
138      , ("leadingSpace", [[" abc"]],         " abc\r\n")
139      , ("comma",        [["abc,def"]],      "abc,def\r\n")
140      , ("twoFields",    [["abc","def"]],    "abc,def\r\n")
141      , ("twoRecords",   [["abc"], ["def"]], "abc\r\ndef\r\n")
142      , ("newline",      [["abc\ndef"]],     "abc\ndef\r\n")
143      ]
144    , testGroup "encode" $ map encodeTestAllqtd
145      [ ("simple",       [["abc"]],          "\"abc\"\r\n")
146      , ("quoted",       [["\"abc\""]],      "\"\"\"abc\"\"\"\r\n")
147      , ("quote",        [["a\"b"]],         "\"a\"\"b\"\r\n")
148      , ("quotedQuote",  [["\"a\"b\""]],     "\"\"\"a\"\"b\"\"\"\r\n")
149      , ("leadingSpace", [[" abc"]],         "\" abc\"\r\n")
150      , ("comma",        [["abc,def"]],      "\"abc,def\"\r\n")
151      , ("twoFields",    [["abc","def"]],    "\"abc\",\"def\"\r\n")
152      , ("twoRecords",   [["abc"], ["def"]], "\"abc\"\r\n\"def\"\r\n")
153      , ("newline",      [["abc\ndef"]],     "\"abc\ndef\"\r\n")
154      ]
155
156    , testGroup "encodeWith"
157      [ testCase "tab-delim" $ encodesWithAs (defEnc { encDelimiter = 9 })
158        [["1", "2"]] "1\t2\r\n"
159      , testCase "newline" $ encodesWithAs (defEnc {encUseCrLf = False})
160        [["1", "2"], ["3", "4"]] "1,2\n3,4\n"
161      ]
162    , testGroup "decode" $ map decodeTest decodeTests
163    , testGroup "decodeWith" $ map decodeWithTest decodeWithTests
164    , testGroup "streaming"
165      [ testGroup "decode" $ map streamingDecodeTest decodeTests
166      , testGroup "decodeWith" $ map streamingDecodeWithTest decodeWithTests
167      ]
168    ]
169  where
170    rfc4180Input = BL8.pack $
171                   "#field1,field2,field3\n" ++
172                   "\"aaa\",\"bb\n" ++
173                   "b\",\"ccc\"\n" ++
174                   "\"a,a\",\"b\"\"bb\",\"ccc\"\n" ++
175                   "zzz,yyy,xxx\n"
176    rfc4180Output = [["#field1", "field2", "field3"],
177                     ["aaa", "bb\nb", "ccc"],
178                     ["a,a", "b\"bb", "ccc"],
179                     ["zzz", "yyy", "xxx"]]
180    decodeTests =
181        [ ("simple",       "a,b,c\n",        [["a", "b", "c"]])
182        , ("crlf",         "a,b\r\nc,d\r\n", [["a", "b"], ["c", "d"]])
183        , ("noEol",        "a,b,c",          [["a", "b", "c"]])
184        , ("blankLine",    "a,b,c\n\nd,e,f\n\n",
185           [["a", "b", "c"], ["d", "e", "f"]])
186        , ("leadingSpace", " a,  b,   c\n",  [[" a", "  b", "   c"]])
187        , ("rfc4180", rfc4180Input, rfc4180Output)
188        ]
189    decodeWithTests =
190        [ ("tab-delim", defDec { decDelimiter = 9 }, "1\t2", [["1", "2"]])
191        ]
192
193    encodeTest (name, input, expected) =
194        testCase name $ input `encodesAs` expected
195    encodeTestUnqtd (name, input, expected) =
196        testCase name $ encodesWithAs defEncNoneEnq input expected
197    encodeTestAllqtd (name, input, expected) =
198        testCase name $ encodesWithAs defEncAllEnq input expected
199    decodeTest (name, input, expected) =
200        testCase name $ input `decodesAs` expected
201    decodeWithTest (name, opts, input, expected) =
202        testCase name $ decodesWithAs opts input expected
203    streamingDecodeTest (name, input, expected) =
204        testCase name $ input `decodesStreamingAs` expected
205    streamingDecodeWithTest (name, opts, input, expected) =
206        testCase name $ decodesWithStreamingAs opts input expected
207    defEnc = defaultEncodeOptions
208    defEncNoneEnq = defaultEncodeOptions { encQuoting = QuoteNone }
209    defEncAllEnq  = defaultEncodeOptions { encQuoting = QuoteAll  }
210    defDec = defaultDecodeOptions
211
212nameBasedTests :: [TF.Test]
213nameBasedTests =
214    [ testGroup "encode" $ map encodeTest
215      [ ("simple", ["field"], [[("field", "abc")]], "field\r\nabc\r\n")
216      , ("twoFields", ["field1", "field2"],
217         [[("field1", "abc"), ("field2", "def")]],
218         "field1,field2\r\nabc,def\r\n")
219      , ("twoRecords", ["field"], [[("field", "abc")], [("field", "def")]],
220         "field\r\nabc\r\ndef\r\n")
221      ]
222    , testGroup "encodeWith" $ map encodeWithTest
223      [ ("no header", defEnc {encIncludeHeader = False}, ["field"],
224         [[("field", "abc")]], "abc\r\n")
225      ]
226    , testGroup "decode" $ map decodeTest decodeTests
227    , testGroup "streaming"
228      [ testGroup "decode" $ map streamingDecodeTest decodeTests
229      ]
230    ]
231  where
232    decodeTests =
233        [ ("simple", "field\r\nabc\r\n", ["field"], [[("field", "abc")]])
234        , ("twoFields", "field1,field2\r\nabc,def\r\n", ["field1", "field2"],
235           [[("field1", "abc"), ("field2", "def")]])
236        , ("twoRecords", "field\r\nabc\r\ndef\r\n", ["field"],
237           [[("field", "abc")], [("field", "def")]])
238        , ("cr header", "field\rabc", ["field"], [[("field", "abc")]])
239        , ("cr trailing", "field\rabc\r", ["field"], [[("field", "abc")]])
240        , ("cr separator", "field\rabc\rdef", ["field"], [[("field", "abc")],[("field","def")]])
241        ]
242
243    encodeTest (name, hdr, input, expected) =
244        testCase name $ namedEncodesAs hdr input expected
245    encodeWithTest (name, opts, hdr, input, expected) =
246        testCase name $ namedEncodesWithAs opts hdr input expected
247    decodeTest (name, input, hdr, expected) =
248        testCase name $ namedDecodesAs input hdr expected
249    streamingDecodeTest (name, input, hdr, expected) =
250        testCase name $ namedDecodesStreamingAs input hdr expected
251    defEnc = defaultEncodeOptions
252
253------------------------------------------------------------------------
254-- Conversion tests
255
256-- A single column with an empty string is indistinguishable from an
257-- empty line (which we will ignore.) We therefore encode at least two
258-- columns.
259roundTrip :: (Eq a, FromField a, ToField a) => a -> Bool
260roundTrip x = Right (V.fromList record) == decode NoHeader (encode record)
261  where record = [(x, dummy)]
262        dummy = 'a'
263
264roundTripUnicode :: T.Text -> Assertion
265roundTripUnicode x = Right (V.fromList record) @=?
266                     decode NoHeader (encode record)
267  where record = [(x, dummy)]
268        dummy = 'a'
269
270boundary :: forall a. (Bounded a, Eq a, FromField a, ToField a) => a -> Bool
271boundary _dummy = roundTrip (minBound :: a) && roundTrip (maxBound :: a)
272
273partialDecode :: Parser a -> Assertion
274partialDecode p = case runParser p of
275  Left _  -> return ()
276  Right _ -> assertFailure "expected partial field decode"
277
278expect :: (Eq a, Show a) => Parser a -> a -> Assertion
279expect p a0 =
280  case runParser p of
281    Right a -> a @=? a0
282    Left  e -> assertFailure e
283
284conversionTests :: [TF.Test]
285conversionTests =
286    [ testGroup "roundTrip"
287      [ testProperty "Char" (roundTrip :: Char -> Bool)
288      , testProperty "ByteString" (roundTrip :: B.ByteString -> Bool)
289      , testProperty "Int" (roundTrip :: Int -> Bool)
290      , testProperty "Integer" (roundTrip :: Integer -> Bool)
291      , testProperty "Int8" (roundTrip :: Int8 -> Bool)
292      , testProperty "Int16" (roundTrip :: Int16 -> Bool)
293      , testProperty "Int32" (roundTrip :: Int32 -> Bool)
294      , testProperty "Int64" (roundTrip :: Int64 -> Bool)
295      , testProperty "Natural" (roundTrip :: Natural -> Bool)
296      , testProperty "Word" (roundTrip :: Word -> Bool)
297      , testProperty "Word8" (roundTrip :: Word8 -> Bool)
298      , testProperty "Word16" (roundTrip :: Word16 -> Bool)
299      , testProperty "Word32" (roundTrip :: Word32 -> Bool)
300      , testProperty "Word64" (roundTrip :: Word64 -> Bool)
301      , testProperty "Scientific" (roundTrip :: Scientific -> Bool)
302      , testProperty "lazy ByteString"
303        (roundTrip :: BL.ByteString -> Bool)
304      , testProperty "Text" (roundTrip :: T.Text -> Bool)
305      , testProperty "lazy Text" (roundTrip :: LT.Text -> Bool)
306      ]
307    , testGroup "boundary"
308      [ testProperty "Int" (boundary (undefined :: Int))
309      , testProperty "Int8" (boundary (undefined :: Int8))
310      , testProperty "Int16" (boundary (undefined :: Int16))
311      , testProperty "Int32" (boundary (undefined :: Int32))
312      , testProperty "Int64" (boundary (undefined :: Int64))
313      , testProperty "Word" (boundary (undefined :: Word))
314      , testProperty "Word8" (boundary (undefined :: Word8))
315      , testProperty "Word16" (boundary (undefined :: Word16))
316      , testProperty "Word32" (boundary (undefined :: Word32))
317      , testProperty "Word64" (boundary (undefined :: Word64))
318      ]
319    , testGroup "Unicode"
320      [ testCase "Chinese" (roundTripUnicode "我能吞下玻璃而不伤身体。")
321      , testCase "Icelandic" (roundTripUnicode
322                              "Sævör grét áðan því úlpan var ónýt.")
323      , testCase "Turkish" (roundTripUnicode
324                            "Cam yiyebilirim, bana zararı dokunmaz.")
325      ]
326    , testGroup "Partial Decodes"
327      [ testCase "Int"         (partialDecode
328                                (parseField "12.7" :: Parser Int))
329      , testCase "Natural"     (partialDecode
330                                (parseField "12.7" :: Parser Natural))
331      , testCase "Word"        (partialDecode
332                                (parseField "12.7" :: Parser Word))
333      , testCase "Scientific"  (partialDecode
334                                (parseField "1.0+" :: Parser Scientific))
335      , testCase "Double"      (partialDecode
336                                (parseField "1.0+" :: Parser Double))
337      , testCase "Integer"     (partialDecode
338                                (parseField "1e6"  :: Parser Integer))
339      ]
340    , testGroup "Space trimming"
341      [ testCase "_Int"         (expect (parseField " 12"     :: Parser Int)        12)
342      , testCase "Int_"         (expect (parseField "12 "     :: Parser Int)        12)
343      , testCase "_Int_"        (expect (parseField " 12 "    :: Parser Int)        12)
344      , testCase "_Natural"     (expect (parseField " 12"     :: Parser Natural)    12)
345      , testCase "Natural_"     (expect (parseField "12 "     :: Parser Natural)    12)
346      , testCase "_Natural_"    (expect (parseField " 12 "    :: Parser Natural)    12)
347      , testCase "_Word"        (expect (parseField " 12"     :: Parser Word)       12)
348      , testCase "Word_"        (expect (parseField "12 "     :: Parser Word)       12)
349      , testCase "_Word_"       (expect (parseField " 12 "    :: Parser Word)       12)
350      , testCase "_Scientific"  (expect (parseField " 1.2e1"  :: Parser Scientific) 12)
351      , testCase "Scientific_"  (expect (parseField "1.2e1 "  :: Parser Scientific) 12)
352      , testCase "_Scientific_" (expect (parseField " 1.2e1 " :: Parser Scientific) 12)
353      , testCase "_Double"      (expect (parseField " 1.2e1"  :: Parser Double)     12)
354      , testCase "Double_"      (expect (parseField "1.2e1 "  :: Parser Double)     12)
355      , testCase "_Double_"     (expect (parseField " 1.2e1 " :: Parser Double)     12)
356      ]
357    ]
358
359------------------------------------------------------------------------
360-- Custom options tests
361
362customDelim :: Word8 -> B.ByteString -> B.ByteString -> Property
363customDelim delim f1 f2 = delim `notElem` [cr, nl, dquote] ==>
364    (decodeWith decOpts NoHeader (encodeWith encOpts [V.fromList [f1, f2]]) ==
365     Right (V.fromList [V.fromList [f1, f2]]))
366  where
367    encOpts = defaultEncodeOptions { encDelimiter = delim }
368    decOpts = defaultDecodeOptions { decDelimiter = delim }
369    nl = 10
370    cr = 13
371    dquote = 34
372
373customOptionsTests :: [TF.Test]
374customOptionsTests =
375    [ testProperty "customDelim" customDelim
376    ]
377
378------------------------------------------------------------------------
379-- Instance tests
380
381instanceTests :: [TF.Test]
382instanceTests =
383  [
384    testGroup "Records instances"
385    [ testCase "foldr Foldable" (expected @=? F.foldr (:) [] input)
386    , testCase "foldl' Foldable" (expected @=? F.foldl' (flip (:)) [] input)
387    ]
388  ]
389  where
390    input = S.Cons (Left "empty") (
391      S.Cons (Right ("a" :: String)) (S.Nil Nothing BL8.empty))
392    expected = ["a" :: String]
393
394------------------------------------------------------------------------
395-- Custom conversion option tests
396
397genericConversionTests :: [TF.Test]
398genericConversionTests =
399    [ testCase "headerOrder" (header ["column1", "column2", "column_3"] @=? hdrs)
400    , testCase "encode" (encodeDefaultOrderedByName sampleValues @?= sampleEncoding)
401    , testCase "decode" (Right (hdrs, V.fromList sampleValues) @=? decodeByName sampleEncoding)
402    , testProperty "roundTrip" rtProp
403    ]
404  where
405    hdrs = headerOrder (undefined :: SampleType)
406
407    sampleValues = [ SampleType ""      1     Nothing
408                   , SampleType "field" 99999 (Just 1.234)
409                   ]
410
411    sampleEncoding = "column1,column2,column_3\r\n,1,\r\nfield,99999,1.234\r\n"
412
413    rtProp :: [SampleType] -> Bool
414    rtProp vs = Right (hdrs, V.fromList vs)
415                == decodeByName (encodeDefaultOrderedByName vs)
416
417data SampleType = SampleType
418  { _column1  :: !T.Text
419  , column2   :: !Int
420  , _column_3 :: !(Maybe Double)
421  } deriving (Eq, Show, Read, Generic)
422
423sampleOptions :: Options
424sampleOptions = defaultOptions { fieldLabelModifier = rmUnderscore }
425  where
426    rmUnderscore ('_':str) = str
427    rmUnderscore str       = str
428
429instance ToNamedRecord SampleType where
430  toNamedRecord = genericToNamedRecord sampleOptions
431
432instance FromNamedRecord SampleType where
433  parseNamedRecord = genericParseNamedRecord sampleOptions
434
435instance DefaultOrdered SampleType where
436  headerOrder = genericHeaderOrder sampleOptions
437
438instance Arbitrary SampleType where
439  arbitrary = SampleType <$> arbitrary <*> arbitrary <*> arbitrary
440
441------------------------------------------------------------------------
442-- Test harness
443
444allTests :: [TF.Test]
445allTests = [ testGroup "positional" positionalTests
446           , testGroup "named" nameBasedTests
447           , testGroup "conversion" conversionTests
448           , testGroup "custom-options" customOptionsTests
449           , testGroup "instances" instanceTests
450           , testGroup "generic-conversions" genericConversionTests
451           ]
452
453main :: IO ()
454main = defaultMain allTests
455