123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105 |
- {-# LANGUAGE OverloadedStrings #-}
-
- {-
-
- This file is part of the Haskell package cassava-streams. It is
- subject to the license terms in the LICENSE file found in the
- top-level directory of this distribution and at
- git://pmade.com/cassava-streams/LICENSE. No part of cassava-streams
- package, including this file, may be copied, modified, propagated, or
- distributed except according to the terms contained in the LICENSE
- file.
-
- -}
-
- --------------------------------------------------------------------------------
- module Main (main) where
-
- --------------------------------------------------------------------------------
- import Control.Monad
- import Data.ByteString (ByteString)
- import qualified Data.ByteString as BS
- import Data.Csv hiding (Record, NamedRecord, record, header)
- import qualified Data.Vector as V
- import System.IO.Streams (InputStream, OutputStream)
- import qualified System.IO.Streams as Streams
- import qualified System.IO.Streams.Csv as CSV
- import Test.QuickCheck.Monadic (monadicIO, run, assert)
- import Test.Tasty
- import Test.Tasty.QuickCheck as QC
-
- --------------------------------------------------------------------------------
- -- | Fake record to encode and decode. This works well because
- -- Cassava and QuickCheck already have the necessary instances for
- -- triples.
- type Record = (Int, String, String)
-
- --------------------------------------------------------------------------------
- -- | But, Cassava doesn't have ToNamedRecord, FromNamedRecord
- -- instances for triples so we have to work around there here.
- newtype NamedRecord = NamedRecord {record :: Record}
-
- instance ToNamedRecord NamedRecord where
- toNamedRecord (NamedRecord (a, b, c)) =
- namedRecord ["a" .= a, "b" .= b, "c" .= c]
-
- instance FromNamedRecord NamedRecord where
- parseNamedRecord m = do
- a <- m .: "a"
- b <- m .: "b"
- c <- m .: "c"
- return $ NamedRecord (a, b, c)
-
-
- --------------------------------------------------------------------------------
- header :: Header
- header = V.fromList ["a", "b", "c"]
-
- --------------------------------------------------------------------------------
- -- | Given a list of records generated by QuickCheck, encode those
- -- records into a CSV ByteString then decode them back into records.
- roundTrip :: (InputStream ByteString -> IO (InputStream a)) -- ^ Decoder.
- -> (OutputStream ByteString -> IO (OutputStream a)) -- ^ Encoder.
- -> [a] -- ^ Records.
- -> IO [a]
- roundTrip is os recs = do
- -- Encode records to a ByteString.
- sourceList <- Streams.fromList recs
- (collector, encoded) <- Streams.listOutputStream
- encoder <- os collector
- Streams.connect sourceList encoder
-
- -- Decode from ByteString.
- decoder <- fmap BS.concat encoded >>= Streams.fromByteString >>= is
- (decodeStream, decoded) <- Streams.listOutputStream
- Streams.connect decoder decodeStream
- decoded
-
- --------------------------------------------------------------------------------
- prop_namedRoundTrip :: [Record] -> Property
- prop_namedRoundTrip recsIn = not (null recsIn) ==> monadicIO $ do
- recsOut <- run $ roundTrip is os (map NamedRecord recsIn)
- assert $ recsIn == map record recsOut
- where
- is = CSV.decodeStreamByName >=> CSV.onlyValidRecords
- os = CSV.encodeStreamByName header
-
- --------------------------------------------------------------------------------
- prop_indexedRoundTrip :: [Record] -> Property
- prop_indexedRoundTrip recsIn = not (null recsIn) ==> monadicIO $ do
- recsOut <- run $ roundTrip is os recsIn
- assert $ recsIn == recsOut
- where
- is = CSV.decodeStream NoHeader >=> CSV.onlyValidRecords
- os = CSV.encodeStream
-
- --------------------------------------------------------------------------------
- tests :: TestTree
- tests = testGroup "Tests"
- [ QC.testProperty "namedRoundTrip" prop_namedRoundTrip
- , QC.testProperty "indexedRoundTrip" prop_indexedRoundTrip
- ]
-
- --------------------------------------------------------------------------------
- main :: IO ()
- main = defaultMain tests
|