blob: eae2a867b66487e04a2beb96a1f609ee2840e0b7 [file] [log] [blame]
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
--
-- See license.txt for details
module Main (tests, main) where
import Control.Concurrent
import qualified Control.Exception as Exc
import Control.Monad.IO.Class (liftIO)
import Data.Bits ((.&.))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Data.Char (chr)
import Data.Functor.Identity (Identity, runIdentity)
import qualified Data.List as L
import qualified Data.List.Split as LS
import Data.Monoid (mappend, mempty, mconcat)
import Data.String (IsString, fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import Data.Word (Word8)
import System.Timeout (timeout)
import Test.Chell
import Test.Chell.QuickCheck
import Test.QuickCheck hiding ((.&.), property, within)
import Test.QuickCheck.Poly (A, B, C)
import Data.Enumerator (($$), (>>==))
import qualified Data.Enumerator as E
import qualified Data.Enumerator.Binary as EB
import qualified Data.Enumerator.Text as ET
import qualified Data.Enumerator.List as EL
tests :: [Suite]
tests =
[ suite_StreamInstances
, suite_Text
, suite_ListAnalogues
, suite_Other
]
main :: IO ()
main = Test.Chell.defaultMain tests
-- Stream instances {{{
suite_StreamInstances :: Suite
suite_StreamInstances = suite "stream-instances"
[ suite_StreamMonoid
, suite_StreamFunctor
, suite_StreamMonad
]
suite_StreamMonoid :: Suite
suite_StreamMonoid = suite "monoid" props where
props = [ property "law-1" prop_law1
, property "law-2" prop_law2
, property "law-3" prop_law3
, property "law-4" prop_law4
]
prop_law1 :: E.Stream A -> Bool
prop_law1 x = mappend mempty x == x
prop_law2 :: E.Stream A -> Bool
prop_law2 x = mappend x mempty == x
prop_law3 :: E.Stream A -> E.Stream A -> E.Stream A -> Bool
prop_law3 x y z = mappend x (mappend y z) == mappend (mappend x y) z
prop_law4 :: [E.Stream A] -> Bool
prop_law4 xs = mconcat xs == foldr mappend mempty xs
suite_StreamFunctor :: Suite
suite_StreamFunctor = suite "functor" props where
props = [ property "law-1" prop_law1
, property "law-2" prop_law2
]
prop_law1 :: E.Stream A -> Bool
prop_law1 x = fmap id x == id x
prop_law2 :: E.Stream A -> Blind (B -> C) -> Blind (A -> B) -> Bool
prop_law2 x (Blind f) (Blind g) = fmap (f . g) x == (fmap f . fmap g) x
suite_StreamMonad :: Suite
suite_StreamMonad = suite "Monad Stream" props where
props = [ property "law-1" prop_law1
, property "law-2" prop_law2
, property "law-3" prop_law3
]
prop_law1 :: A -> Blind (A -> E.Stream B) -> Bool
prop_law1 a (Blind f) = (return a >>= f) == f a
prop_law2 :: E.Stream A -> Bool
prop_law2 m = (m >>= return) == m
prop_law3 :: E.Stream A -> Blind (A -> E.Stream B) -> Blind (B -> E.Stream C) -> Bool
prop_law3 m (Blind f) (Blind g) = ((m >>= f) >>= g) == (m >>= (\x -> f x >>= g))
-- }}}
-- Generic properties {{{
test_Enumeratee :: T.Text -> E.Enumeratee A A Identity (Maybe A) -> Suite
test_Enumeratee name enee = suite name props where
props = [ property "incremental" prop_incremental
, property "nest-errors" prop_nest_errors
]
prop_incremental (Positive n) (NonEmpty xs) = let
result = runIdentity (E.run_ iter)
expected = (Just (head xs), tail xs)
iter = E.enumList n xs $$ do
a <- E.joinI (enee $$ EL.head)
b <- EL.consume
return (a, b)
in result == expected
prop_nest_errors (Positive n) (NonEmpty xs) = let
result = runIdentity (E.run_ iter)
iter = E.enumList n xs $$ do
_ <- enee $$ E.throwError (Exc.ErrorCall "")
EL.consume
in result == xs
-- }}}
-- Text encoding / decoding {{{
suite_Text :: Suite
suite_Text = suite "text"
[ suite_Encoding
, suite_Decoding
]
suite_Encoding :: Suite
suite_Encoding = suite "encoding"
[ suite_Encode_ASCII
, suite_Encode_ISO8859
]
suite_Encode_ASCII :: Suite
suite_Encode_ASCII = suite "ascii" props where
props = [ property "works" (forAll genASCII prop_works)
, property "error" prop_error
, property "lazy" prop_lazy
]
encode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.encode ET.ascii $$ iter)
prop_works bytes = result == map B.singleton words where
Right result = encode EL.consume (map T.singleton chars)
chars = B8.unpack bytes
words = B.unpack bytes
prop_error = isLeft (encode EL.consume input) where
isLeft = either (const True) (const False)
input = [T.pack "\x61\xFF"]
prop_lazy = either (const False) (== expected) result where
result = encode EL.head input
input = [T.pack "\x61\xFF"]
expected = Just (B.singleton 0x61)
suite_Encode_ISO8859 :: Suite
suite_Encode_ISO8859 = suite "iso-8859-1" props where
props = [ property "works" (forAll genISO8859 prop_works)
, property "error" prop_error
, property "lazy" prop_lazy
]
encode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.encode ET.iso8859_1 $$ iter)
prop_works bytes = result == map B.singleton words where
Right result = encode EL.consume (map T.singleton chars)
chars = B8.unpack bytes
words = B.unpack bytes
prop_error = isLeft (encode EL.consume input) where
isLeft = either (const True) (const False)
input = [T.pack "\x61\xFF5E"]
prop_lazy = either (const False) (== expected) result where
result = encode EL.head input
input = [T.pack "\x61\xFF5E"]
expected = Just (B.singleton 0x61)
suite_Decoding :: Suite
suite_Decoding = suite "decoding"
[ suite_Decode_ASCII
, suite_Decode_UTF8
, suite_Decode_UTF16_BE
, suite_Decode_UTF16_LE
, suite_Decode_UTF32_BE
, suite_Decode_UTF32_LE
]
suite_Decode_ASCII :: Suite
suite_Decode_ASCII = suite "ascii" props where
props = [ property "works" (forAll genASCII prop_works)
, property "error" prop_error
, property "lazy" prop_lazy
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.ascii $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf8 text)
chars = T.unpack text
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0xFF]]
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0xFF]]
expected = Just (T.pack "a")
suite_Decode_UTF8 :: Suite
suite_Decode_UTF8 = suite "utf-8" props where
props = [ property "works" prop_works
, property "error" prop_error
, property "lazy" prop_lazy
, property "incremental" prop_incremental
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.utf8 $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf8 text)
chars = T.unpack text
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0x61, 0x80]]
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0x80]]
expected = Just (T.pack "a")
prop_incremental = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0xC2, 0xC2]]
expected = Just (T.pack "a")
suite_Decode_UTF16_BE :: Suite
suite_Decode_UTF16_BE = suite "utf-16-be" props where
props = [ property "works" prop_works
, property "lazy" prop_lazy
, property "error" prop_error
, property "incremental" prop_incremental
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.utf16_be $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf16BE text)
chars = T.unpack text
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x00, 0x61, 0xDD, 0x1E]]
expected = Just (T.pack "a")
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0x00, 0x61, 0xDD, 0x1E]]
prop_incremental = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x00, 0x61, 0xD8, 0x34, 0xD8, 0xD8]]
expected = Just (T.pack "a")
suite_Decode_UTF16_LE :: Suite
suite_Decode_UTF16_LE = suite "utf-16-le" props where
props = [ property "works" prop_works
, property "lazy" prop_lazy
, property "error" prop_error
, property "incremental" prop_incremental
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.utf16_le $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf16LE text)
chars = T.unpack text
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0x00, 0x1E, 0xDD]]
expected = Just (T.pack "a")
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0x61, 0x00, 0x1E, 0xDD]]
prop_incremental = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0x00, 0x34, 0xD8, 0xD8, 0xD8]]
expected = Just (T.pack "a")
suite_Decode_UTF32_BE :: Suite
suite_Decode_UTF32_BE = suite "utf-32-be" props where
props = [ property "works" prop_works
, property "lazy" prop_lazy
, property "error" prop_error
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.utf32_be $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf32BE text)
chars = T.unpack text
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x00, 0x00, 0x00, 0x61, 0xFF, 0xFF]]
expected = Just (T.pack "a")
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0xFF, 0xFF, 0xFF, 0xFF]]
suite_Decode_UTF32_LE :: Suite
suite_Decode_UTF32_LE = suite "utf-32-le" props where
props = [ property "works" prop_works
, property "lazy" prop_lazy
, property "error" prop_error
]
decode iter input =
runIdentity . E.run $
E.enumList 1 input $$
E.joinI (ET.decode ET.utf32_le $$ iter)
prop_works text = result == map T.singleton chars where
Right result = decode EL.consume (map B.singleton bytes)
bytes = B.unpack (TE.encodeUtf32LE text)
chars = T.unpack text
prop_lazy = either (const False) (== expected) result where
result = decode EL.head input
input = [B.pack [0x61, 0x00, 0x00, 0x00, 0xFF, 0xFF]]
expected = Just (T.pack "a")
prop_error = isLeft (decode EL.consume input) where
isLeft = either (const True) (const False)
input = [B.pack [0xFF, 0xFF, 0xFF, 0xFF]]
-- }}}
-- List analogues {{{
suite_ListAnalogues :: Suite
suite_ListAnalogues = suite "list-analogues"
[ suite_Consume
, suite_Head
, suite_Drop
, suite_Take
, suite_Require
, suite_Isolate
, suite_SplitWhen
, suite_Map
, suite_ConcatMap
, suite_MapM
, suite_ConcatMapM
, suite_MapAccum
, suite_MapAccumM
, suite_Filter
, suite_FilterM
]
check :: Eq b => E.Iteratee a Identity b -> ([a] -> Either Exc.ErrorCall b) -> [a] -> Bool
check iter plain xs = expected == run iter xs where
expected = case plain xs of
Left exc -> Left (Just exc)
Right x -> Right x
run iter xs = case runIdentity (E.run (E.enumList 1 xs $$ iter)) of
Left exc -> Left (Exc.fromException exc)
Right x -> Right x
testListAnalogue name iterList plainList iterText plainText iterBytes plainBytes = suite name tests where
tests = [ property "list" prop_List
, property "text" prop_Text
, property "bytes" prop_Bytes
]
prop_List :: [A] -> Bool
prop_List xs = check iterList plainList xs
prop_Text xs = check iterText (plainText . TL.fromChunks) xs
prop_Bytes xs = check iterBytes (plainBytes . BL.fromChunks) xs
testListAnalogueN name iterList plainList iterText plainText iterBytes plainBytes = suite name tests where
tests = [ property "list" prop_List
, property "text" prop_Text
, property "bytes" prop_Bytes
]
prop_List :: Positive Integer -> [A] -> Bool
prop_List (Positive n) xs = check (iterList n) (plainList n) xs
prop_Text (Positive n) xs = check (iterText n) (plainText n . TL.fromChunks) xs
prop_Bytes (Positive n) xs = check (iterBytes n) (plainBytes n . BL.fromChunks) xs
testListAnalogueX name iterList plainList iterText plainText iterBytes plainBytes = suite name tests where
tests = [ property "list" prop_List
, property "text" prop_Text
, property "bytes" prop_Bytes
]
prop_List :: A -> [A] -> Bool
prop_List x xs = check (iterList x) (plainList x) xs
prop_Text x xs = check (iterText x) (plainText x . TL.fromChunks) xs
prop_Bytes x xs = check (iterBytes x) (plainBytes x . BL.fromChunks) xs
suite_Consume :: Suite
suite_Consume = testListAnalogue "consume"
EL.consume Right
ET.consume Right
EB.consume Right
suite_Head :: Suite
suite_Head = testListAnalogue "head"
(do
x <- EL.head
extra <- EL.consume
return (x, extra)
)
(\xs -> Right $ case xs of
[] -> (Nothing, [])
(x:xs') -> (Just x, xs'))
(do
x <- ET.head
extra <- ET.consume
return (x, extra)
)
(\text -> Right $ case TL.uncons text of
Nothing -> (Nothing, TL.empty)
Just (x, extra) -> (Just x, extra))
(do
x <- EB.head
extra <- EB.consume
return (x, extra)
)
(\bytes -> Right $ case BL.uncons bytes of
Nothing -> (Nothing, BL.empty)
Just (x, extra) -> (Just x, extra))
suite_Drop :: Suite
suite_Drop = testListAnalogueN "drop"
(\n -> EL.drop n >> EL.consume)
(\n -> Right . L.genericDrop n)
(\n -> ET.drop n >> ET.consume)
(\n -> Right . TL.drop (fromInteger n))
(\n -> EB.drop n >> EB.consume)
(\n -> Right . BL.drop (fromInteger n))
suite_Take :: Suite
suite_Take = testListAnalogueN "take"
(\n -> do
xs <- EL.take n
extra <- EL.consume
return (xs, extra))
(\n -> Right . L.genericSplitAt n)
(\n -> do
xs <- ET.take n
extra <- ET.consume
return (xs, extra))
(\n -> Right . TL.splitAt (fromInteger n))
(\n -> do
xs <- EB.take n
extra <- EB.consume
return (xs, extra))
(\n -> Right . BL.splitAt (fromInteger n))
suite_Require :: Suite
suite_Require = testListAnalogueN "require"
(\n -> do
EL.require n
EL.consume)
(\n xs -> if n > toInteger (length xs)
then Left (Exc.ErrorCall "require: Unexpected EOF")
else Right xs)
(\n -> do
ET.require n
ET.consume)
(\n xs -> if n > toInteger (TL.length xs)
then Left (Exc.ErrorCall "require: Unexpected EOF")
else Right xs)
(\n -> do
EB.require n
EB.consume)
(\n xs -> if n > toInteger (BL.length xs)
then Left (Exc.ErrorCall "require: Unexpected EOF")
else Right xs)
suite_Isolate :: Suite
suite_Isolate = testListAnalogue "isolate"
(do
x <- E.joinI (EL.isolate 2 $$ EL.head)
extra <- EL.consume
return (x, extra))
(\xs -> Right $ case xs of
[] -> (Nothing, [])
(x:[]) -> (Just x, [])
(x:_:xs') -> (Just x, xs'))
(do
x <- E.joinI (ET.isolate 2 $$ ET.head)
extra <- ET.consume
return (x, extra))
(\text -> Right $ case TL.unpack text of
[] -> (Nothing, TL.empty)
(x:[]) -> (Just x, TL.empty)
(x:_:xs') -> (Just x, TL.pack xs'))
(do
x <- E.joinI (EB.isolate 2 $$ EB.head)
extra <- EB.consume
return (x, extra))
(\bytes -> Right $ case BL.unpack bytes of
[] -> (Nothing, BL.empty)
(x:[]) -> (Just x, BL.empty)
(x:_:xs) -> (Just x, BL.pack xs))
suite_SplitWhen :: Suite
suite_SplitWhen = testListAnalogueX "splitWhen"
(\x -> do
xs <- E.joinI (EL.splitWhen (== x) $$ EL.consume)
extra <- EL.consume
return (xs, extra))
(\x xs -> let
split = LS.split . LS.dropFinalBlank . LS.dropDelims . LS.whenElt
in Right (split (== x) xs, []))
(\c -> do
xs <- E.joinI (ET.splitWhen (== c) $$ EL.consume)
extra <- EL.consume
return (xs, extra))
(\c text -> let
split = LS.split . LS.dropFinalBlank . LS.dropDelims . LS.whenElt
chars = TL.unpack text
in Right (map T.pack (split (== c) chars), []))
(\x -> do
xs <- E.joinI (EB.splitWhen (== x) $$ EL.consume)
extra <- EL.consume
return (xs, extra))
(\x bytes -> let
split = LS.split . LS.dropFinalBlank . LS.dropDelims . LS.whenElt
words = BL.unpack bytes
in Right (map B.pack (split (== x) words), []))
suite_Map :: Suite
suite_Map = test_Enumeratee "map" (EL.map id)
suite_ConcatMap :: Suite
suite_ConcatMap = test_Enumeratee "concatMap" (EL.concatMap (:[]))
suite_MapM :: Suite
suite_MapM = test_Enumeratee "mapM" (EL.mapM return)
suite_ConcatMapM :: Suite
suite_ConcatMapM = test_Enumeratee "concatMapM" (EL.concatMapM (\x -> return [x]))
suite_MapAccum :: Suite
suite_MapAccum = testListAnalogue "mapAccum"
(do
let enee = EL.mapAccum (\s ao -> (s+1, (s, ao))) 10
a <- E.joinI (enee $$ EL.head)
b <- EL.consume
return (a, b))
(\xs -> Right $ case xs of
[] -> (Nothing, [])
(x:xs') -> (Just (10, x), xs'))
(do
let enee = ET.mapAccum (\s ao -> (s+1, succ ao)) 10
a <- E.joinI (enee $$ EL.head)
b <- ET.consume
return (a, b))
(\text -> Right $ case TL.uncons text of
Nothing -> (Nothing, TL.empty)
Just (c, text') -> (Just (T.singleton (succ c)), text'))
(do
let enee = EB.mapAccum (\s ao -> (s+1, ao + s)) 10
a <- E.joinI (enee $$ EL.head)
b <- EB.consume
return (a, b))
(\bytes -> Right $ case BL.uncons bytes of
Nothing -> (Nothing, BL.empty)
Just (b, bytes') -> (Just (B.singleton (b + 10)), bytes'))
suite_MapAccumM :: Suite
suite_MapAccumM = testListAnalogue "mapAccumM"
(do
let enee = EL.mapAccumM (\s ao -> return (s+1, (s, ao))) 10
a <- E.joinI (enee $$ EL.head)
b <- EL.consume
return (a, b))
(\xs -> Right $ case xs of
[] -> (Nothing, [])
(x:xs') -> (Just (10, x), xs'))
(do
let enee = ET.mapAccumM (\s ao -> return (s+1, succ ao)) 10
a <- E.joinI (enee $$ EL.head)
b <- ET.consume
return (a, b))
(\text -> Right $ case TL.uncons text of
Nothing -> (Nothing, TL.empty)
Just (c, text') -> (Just (T.singleton (succ c)), text'))
(do
let enee = EB.mapAccumM (\s ao -> return (s+1, ao + s)) 10
a <- E.joinI (enee $$ EL.head)
b <- EB.consume
return (a, b))
(\bytes -> Right $ case BL.uncons bytes of
Nothing -> (Nothing, BL.empty)
Just (b, bytes') -> (Just (B.singleton (b + 10)), bytes'))
suite_Filter :: Suite
suite_Filter = test_Enumeratee "filter" (EL.filter (\_ -> True))
suite_FilterM :: Suite
suite_FilterM = test_Enumeratee "filterM" (EL.filterM (\_ -> return True))
-- }}}
-- Specific functions
suite_Other :: Suite
suite_Other = suite "other"
[ test_Sequence
, test_joinE
, suite "catchError"
[ test test_CatchError_WithoutContinue
, test test_CatchError_NotDivergent
, test test_CatchError_Interleaved
]
, test test_Zip
, test test_ZipBytes
, test test_ZipText
]
test_Sequence :: Suite
test_Sequence = property "sequence" prop where
prop :: Positive Integer -> [A] -> Bool
prop (Positive n) xs = result == expected where
result = runIdentity (E.run_ iter)
expected = map Just xs
iter = E.enumList n xs $$ E.joinI (E.sequence EL.head $$ EL.consume)
test_joinE :: Suite
test_joinE = property "joinE" prop where
prop :: [Integer] -> Bool
prop xs = result == expected where
result = runIdentity (E.run_ iter)
expected = map (* 10) xs
iter = (E.joinE (E.enumList 1 xs) (EL.map (* 10))) $$ EL.consume
test_CatchError_WithoutContinue :: Test
test_CatchError_WithoutContinue = assertions "without-continue" $ do
let iter = E.catchError
(E.throwError (Exc.ErrorCall "error"))
(\_ -> EL.require 1)
res <- E.run (E.enumList 1 [] $$ iter)
$assert (left res)
let Left err = res
$assert $ equal (Exc.fromException err) (Just (Exc.ErrorCall "require: Unexpected EOF"))
test_CatchError_NotDivergent :: Test
test_CatchError_NotDivergent = assertions "not-divergent" $ do
let iter = E.catchError
(do
EL.head
E.throwError (Exc.ErrorCall "error"))
(\_ -> EL.require 1)
res <- E.run (E.enumList 1 [] $$ iter)
$assert (left res)
let Left err = res
$assert $ equal (Exc.fromException err) (Just (Exc.ErrorCall "require: Unexpected EOF"))
test_CatchError_Interleaved :: Test
test_CatchError_Interleaved = within 1000 $ assertions "interleaved" $ do
let enumMVar mvar = EL.repeatM (liftIO (takeMVar mvar))
let iter mvar = do
liftIO (putMVar mvar ())
EL.head
return True
let onError err = return False
mvar <- liftIO newEmptyMVar
E.run_ (enumMVar mvar $$ E.catchError (iter mvar) onError)
test_Zip :: Test
test_Zip = assertions "zip" $ do
let iterTup = do
Just x <- EL.head
Just y <- EL.head
return (x, y)
let iterTupFlip = do
Just x <- EL.head
Just y <- EL.head
return (y, x)
let check i1 i2 = E.run_ (E.enumList 4 [1, 2, 3, 4, 5] $$ do
(x, y) <- EL.zip i1 i2
extra <- EL.consume
return (x, y, extra))
-- Both sides have same behavior
(tup, tup2, extra) <- check iterTup iterTupFlip
$expect (equal tup (1, 2))
$expect (equal tup2 (2, 1))
$expect (equal extra [3, 4, 5])
-- First side has more extra data
(took, tup, extra) <- check (EL.take 1) iterTup
$expect (equal took [1])
$expect (equal tup (1, 2))
$expect (equal extra [3, 4, 5])
-- Second side has more extra data
(tup, took, extra) <- check iterTup (EL.take 1)
$expect (equal tup (1, 2))
$expect (equal took [1])
$expect (equal extra [3, 4, 5])
test_ZipBytes :: Test
test_ZipBytes = assertions "zip-bytes" $ do
let iterTup = do
Just x <- EB.head
Just y <- EB.head
return (x, y)
let iterTupFlip = do
Just x <- EB.head
Just y <- EB.head
return (y, x)
let check i1 i2 = E.run_ (E.enumList 2 ["abc", "def", "ghi"] $$ do
(x, y) <- EB.zip i1 i2
extra <- EL.consume
return (x, y, extra))
-- Both sides have same behavior
(tup, tup2, extra) <- check iterTup iterTupFlip
$expect (equal tup (0x61, 0x62))
$expect (equal tup2 (0x62, 0x61))
$expect (equal extra ["c", "def", "ghi"])
-- First side has more extra data
(took, tup, extra) <- check (EB.take 1) iterTup
$expect (equal took "a")
$expect (equal tup (0x61, 0x62))
$expect (equal extra ["c", "def", "ghi"])
-- Second side has more extra data
(tup, took, extra) <- check iterTup (EB.take 1)
$expect (equal tup (0x61, 0x62))
$expect (equal took "a")
$expect (equal extra ["c", "def", "ghi"])
test_ZipText :: Test
test_ZipText = assertions "zip-text" $ do
let iterTup = do
Just x <- ET.head
Just y <- ET.head
return (x, y)
let iterTupFlip = do
Just x <- ET.head
Just y <- ET.head
return (y, x)
let check i1 i2 = E.run_ (E.enumList 2 ["abc", "def", "ghi"] $$ do
(x, y) <- ET.zip i1 i2
extra <- EL.consume
return (x, y, extra))
-- Both sides have same behavior
(tup, tup2, extra) <- check iterTup iterTupFlip
$expect (equal tup ('a', 'b'))
$expect (equal tup2 ('b', 'a'))
$expect (equal extra ["c", "def", "ghi"])
-- First side has more extra data
(took, tup, extra) <- check (ET.take 1) iterTup
$expect (equal took "a")
$expect (equal tup ('a', 'b'))
$expect (equal extra ["c", "def", "ghi"])
-- Second side has more extra data
(tup, took, extra) <- check iterTup (ET.take 1)
$expect (equal tup ('a', 'b'))
$expect (equal took "a")
$expect (equal extra ["c", "def", "ghi"])
-- misc
genASCII :: IsString a => Gen a
genASCII = fmap fromString string where
string = sized $ \n -> do
k <- choose (0,n)
sequence [ char | _ <- [1..k] ]
char = chr `fmap` choose (0,0x7F)
genISO8859 :: IsString a => Gen a
genISO8859 = fmap fromString string where
string = sized $ \n -> do
k <- choose (0,n)
sequence [ char | _ <- [1..k] ]
char = chr `fmap` choose (0,0xFF)
genUnicode :: IsString a => Gen a
genUnicode = fmap fromString string where
string = sized $ \n -> do
k <- choose (0,n)
sequence [ char | _ <- [1..k] ]
excluding :: [a -> Bool] -> Gen a -> Gen a
excluding bad gen = loop where
loop = do
x <- gen
if or (map ($ x) bad)
then loop
else return x
reserved = [lowSurrogate, highSurrogate, noncharacter]
lowSurrogate c = c >= 0xDC00 && c <= 0xDFFF
highSurrogate c = c >= 0xD800 && c <= 0xDBFF
noncharacter c = masked == 0xFFFE || masked == 0xFFFF where
masked = c .&. 0xFFFF
ascii = choose (0,0x7F)
plane0 = choose (0xF0, 0xFFFF)
plane1 = oneof [ choose (0x10000, 0x10FFF)
, choose (0x11000, 0x11FFF)
, choose (0x12000, 0x12FFF)
, choose (0x13000, 0x13FFF)
, choose (0x1D000, 0x1DFFF)
, choose (0x1F000, 0x1FFFF)
]
plane2 = oneof [ choose (0x20000, 0x20FFF)
, choose (0x21000, 0x21FFF)
, choose (0x22000, 0x22FFF)
, choose (0x23000, 0x23FFF)
, choose (0x24000, 0x24FFF)
, choose (0x25000, 0x25FFF)
, choose (0x26000, 0x26FFF)
, choose (0x27000, 0x27FFF)
, choose (0x28000, 0x28FFF)
, choose (0x29000, 0x29FFF)
, choose (0x2A000, 0x2AFFF)
, choose (0x2B000, 0x2BFFF)
, choose (0x2F000, 0x2FFFF)
]
plane14 = choose (0xE0000, 0xE0FFF)
planes = [ascii, plane0, plane1, plane2, plane14]
char = chr `fmap` excluding reserved (oneof planes)
instance Arbitrary a => Arbitrary (E.Stream a) where
arbitrary = frequency
[ (10, return E.EOF)
, (90, fmap E.Chunks arbitrary)
]
instance Arbitrary T.Text where
arbitrary = genUnicode
instance Arbitrary B.ByteString where
arbitrary = genUnicode
instance Eq Exc.ErrorCall where
(Exc.ErrorCall s1) == (Exc.ErrorCall s2) = s1 == s2
-- | Require a test to complete within /n/ milliseconds.
within :: Int -> Test -> Test
within time (Test name io) = Test name $ \opts -> do
res <- timeout (time * 1000) (io opts)
case res of
Just res' -> return res'
Nothing -> return (TestAborted [] (T.pack ("Test timed out after " ++ show time ++ " milliseconds")))