{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main ( main ) where
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Identity
import qualified Data.IORef as IOR
import qualified Data.List as L
import Data.String (fromString)
import qualified Streaming as SM
import Streaming (Of(..))
import qualified Streaming.ByteString as Q
import qualified Streaming.ByteString.Char8 as Q8
import qualified Streaming.ByteString.Internal as QI
import qualified Streaming.Prelude as S
import System.IO
import Test.SmallCheck.Series
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.SmallCheck
import Text.Printf (printf)
listOf :: Monad m => Series m a -> Series m [a]
listOf a = decDepth $
pure [] \/ ((:) <$> a <~> listOf a)
strSeries :: Monad m => Series m String
strSeries = listOf (generate $ const ['a', 'b', '\n'])
strSeriesCrlf :: Monad m => Series m String
strSeriesCrlf = L.concat <$> listOf (generate $ const ["a", "b", "\r\n"])
chunksSeries :: Monad m => Series m [String]
chunksSeries = listOf strSeries
nats :: Monad m => Series m Int
nats = generate $ \d -> [1..d]
fromChunks :: [String] -> Q8.ByteStream Identity ()
fromChunks = Q8.fromChunks . S.each . map B.pack
unix2dos :: String -> String
unix2dos = concatMap $ \c -> if c == '\n' then "\r\n" else [c]
unpackToString :: Q8.ByteStream Identity () -> String
unpackToString = runIdentity . S.toList_ . Q8.unpack
sLines :: Q8.ByteStream Identity () -> [B.ByteString]
sLines
= runIdentity
. S.toList_
. S.mapped Q8.toStrict
. Q8.lines
noNullChunks :: S.Stream (Q8.ByteStream Identity) Identity () -> Bool
noNullChunks = SM.streamFold (\() -> True) runIdentity go
where
go :: Q8.ByteStream Identity Bool -> Bool
go (QI.Empty b) = b
go (QI.Chunk bs sbs) = not (B.null bs) && go sbs
go (QI.Go (Identity sbs)) = go sbs
handleIsOpen :: Assertion
handleIsOpen = do
h <- openBinaryFile "tests/sample.txt" ReadMode
hIsOpen h >>= assertBool "Expected file handle to be open!"
l <- Q8.length_ $ Q8.hGetContents h
l @?= 73
hIsOpen h >>= assertBool "Still expected file handle to be open!"
groupCrash :: Assertion
groupCrash = do
a <- runResourceT . S.sum_ . SM.mapsM Q8.length . Q8.group $ Q8.readFile "tests/groupBy.txt"
a @?= 39925
b <- runResourceT . S.sum_ . SM.mapsM Q8.length . Q8.groupBy (\_ _ -> True) $ Q8.readFile "tests/groupBy.txt"
b @?= 39925
groupCharOrder :: Assertion
groupCharOrder = do
a <- S.toList_ . SM.mapsM Q8.toLazy $ Q8.group $ Q8.fromLazy "1234"
a @?= (["1", "2", "3", "4"] :: [BL.ByteString])
b <- S.toList_ . SM.mapsM Q8.toLazy $ Q8.group $ Q8.fromLazy "1122"
b @?= (["11", "22"] :: [BL.ByteString])
groupByCharOrder :: Assertion
groupByCharOrder = do
-- What about when everything fits into one group?
y <- S.toList_ . SM.mapsM Q8.toLazy $ Q8.groupBy (\_ _ -> True) $ Q8.fromLazy "abcd"
y @?= ["abcd"]
-- Prove it's not an issue with the Char-based wrapper.
z <- S.toList_ . SM.mapsM Q.toLazy $ Q.groupBy (\a b -> a - 1 == b) $ Q.fromLazy "98764321"
z @?= ["98", "76", "43", "21"]
-- Char-based variant
a <- S.toList_ . SM.mapsM Q8.toLazy $ Q8.groupBy (\a b -> succ a == b) $ Q8.fromLazy "12346789"
a @?= ["12", "34", "67", "89"]
b <- S.toList_ . SM.mapsM Q8.toLazy $ Q8.groupBy (on (==) (== '5')) $ Q8.fromLazy "5678"
b @?= ["5", "678"]
goodFindIndex :: Assertion
goodFindIndex = do
assertBool "Expected the length of the string" $ QI.findIndexOrEnd (const False) "1234" == 4
assertBool "Expected 0" $ QI.findIndexOrEnd (const True) "1234" == 0
firstI :: Assertion
firstI = do
l <- runResourceT
. S.length_ -- IO Int
. S.filter (== 'i')
. S.concat -- Stream (Of Char) IO ()
. S.mapped Q8.head -- Stream (Of (Maybe Char)) IO ()
. Q8.denull -- Stream (ByteStream IO) IO ()
. Q8.lines -- Stream (ByteStream IO) IO ()
$ Q8.readFile "tests/groupBy.txt" -- ByteStream IO ()
l @?= 57
emptyChunks :: Assertion
emptyChunks = do
bs <- Q.toLazy_ $ QI.chunkMap (const mempty) "bar"
assertBool "Expected empty chunks" $ Data.ByteString.Lazy.null bs
readIntCases :: Assertion
readIntCases = do
let imax = maxBound :: Int
imin = minBound :: Int
imax1 = fromIntegral imax + 1 :: Integer
imax10 = fromIntegral imax + 10 :: Integer
imin1 = fromIntegral imin - 1 :: Integer
imin10 = fromIntegral imin - 10 :: Integer
smax = B.pack $ show imax
smin = B.pack $ show imin
smax1 = B.pack $ show imax1
smax10 = B.pack $ show imax10
smin1 = B.pack $ show imin1
smin10 = B.pack $ show imin10
maxfill = QI.defaultChunkSize
cnt <- IOR.newIORef 0 -- number of effects in stream.
-- Empty input
IOR.writeIORef cnt 1
res <- Q8.readInt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Chunk ""
$ QI.Empty 0
check cnt res Nothing ("" :> 0)
-- Basic unsigned
IOR.writeIORef cnt 1
res <- Q8.readInt
$ QI.Chunk "123"
$ addEffect cnt
$ QI.Empty 1
check cnt res (Just 123) ("" :> 1)
-- Basic negative
IOR.writeIORef cnt 2
res <- Q8.readInt
$ QI.Chunk "-123"
$ addEffect cnt
$ QI.Chunk "456+789"
$ addEffect cnt
$ QI.Empty 2
check cnt res (Just (-123456)) ("+789" :> 2)
-- minBound with leading whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smin)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smin)
$ addEffect cnt
$ QI.Chunk "-42"
$ addEffect cnt
$ QI.Empty 3
check cnt res (Just imin) ("-42" :> 3)
-- maxBound with leading whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smax)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smax)
$ addEffect cnt
$ QI.Chunk "+42"
$ addEffect cnt
$ QI.Empty 4
check cnt res (Just imax) ("+42" :> 4)
-- minbound-1 with whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smin1)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smin1)
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 5
check cnt res Nothing (smin1 :> 5)
-- maxbound+1 with whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smax1)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smax1)
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 6
check cnt res Nothing (smax1 :> 6)
-- maxBound with explicit plus sign
IOR.writeIORef cnt 2
res <- readIntSkip
$ QI.Chunk " +"
$ addEffect cnt
$ QI.Chunk smax
$ QI.Chunk "tail"
$ addEffect cnt
$ QI.Empty 7
check cnt res (Just imax) ("tail" :> 7)
-- maxBound with almost excessive leading whitepace/zeros
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk (B.replicate (maxfill-1) ' ')
$ addEffect cnt
$ QI.Chunk " +"
$ QI.Chunk (B.replicate (maxfill-1) '0')
$ addEffect cnt
$ QI.Chunk ("000000" `B.append` smax)
$ addEffect cnt
$ QI.Chunk "tail"
$ addEffect cnt
$ QI.Empty 8
check cnt res (Just imax) ("tail" :> 8)
-- (Exactly) too much leading whitespace
IOR.writeIORef cnt 3
res <- readIntSkip
$ QI.Chunk (B.replicate maxfill ' ')
$ addEffect cnt
$ QI.Chunk " 1"
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 9
check cnt res Nothing (" 1" :> 9)
-- (Exactly) too many leading zeros
IOR.writeIORef cnt 3
res <- readIntSkip
$ QI.Chunk (B.replicate maxfill '0')
$ addEffect cnt
$ QI.Chunk "1"
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 10
check cnt res Nothing (B.replicate maxfill '0' `B.append` "1" :> 10)
-- Bare plus
IOR.writeIORef cnt 1
res <- readIntSkip
$ QI.Chunk " +"
$ addEffect cnt
$ QI.Chunk "foo"
$ QI.Empty 11
check cnt res Nothing ("+foo" :> 11)
-- Bare minus
IOR.writeIORef cnt 1
res <- readIntSkip
$ QI.Chunk " -"
$ addEffect cnt
$ QI.Chunk " bar"
$ QI.Empty 12
check cnt res Nothing ("- bar" :> 12)
--
IOR.writeIORef cnt 1
let msg = " nothing to see here move along "
res <- Q8.readInt
$ QI.Chunk msg
$ addEffect cnt
$ QI.Empty 13
check cnt res Nothing (msg :> 13)
-- whitespace-only input
IOR.writeIORef cnt 1
res <- readIntSkip
$ QI.Chunk " "
$ addEffect cnt
$ QI.Chunk "\n"
$ QI.Empty 14
check cnt res Nothing ("" :> 14)
-- maxbound+10 with whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smax10)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smax10)
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 15
check cnt res Nothing (smax10 :> 15)
-- minbound-10 with whitespace
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smin10)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smin10)
$ addEffect cnt
$ QI.Chunk ""
$ addEffect cnt
$ QI.Empty 16
check cnt res Nothing (smin10 :> 16)
-- maxBound with cross-chunk overflow
IOR.writeIORef cnt 4
res <- readIntSkip
$ QI.Chunk " \t\n\v\f\r\xa0"
$ addEffect cnt
$ QI.Chunk (B.take 4 smax)
$ addEffect cnt
$ QI.Chunk (B.drop 4 smax)
$ addEffect cnt
$ QI.Chunk "00"
$ addEffect cnt
$ QI.Empty 17
check cnt res Nothing (smax `B.append` "00" :> 17)
where
-- Count down to zero from initial value
readIntSkip = Q8.readInt . Q8.skipSomeWS
addEffect cnt str = QI.Go $ const str <$> IOR.modifyIORef' cnt pred
check :: IOR.IORef Int
-> Compose (Of (Maybe Int)) (QI.ByteStream IO) Int
-> Maybe Int
-> Of B.ByteString Int
-> Assertion
check cnt (Compose (gotInt :> str)) wantInt (wantStr :> wantR ) = do
( gotStr :> gotR ) <- Q.toStrict str
c <- IOR.readIORef cnt
assertBool ("Correct readInt effects " ++ show wantR) $ c == 0
assertBool ("Correct readInt value " ++ show wantR ++ ": " ++ show gotInt) $ gotInt == wantInt
assertBool ("Correct readInt tail " ++ show wantR ++ ": " ++ show gotStr) $ gotStr == wantStr
assertBool ("Correct readInt residue " ++ show wantR ++ ": " ++ show gotR) $ gotR == wantR
main :: IO ()
main = defaultMain $ testGroup "Tests"
[ testGroup "Property Tests"
[ testProperty "Streaming.ByteString.Char8.lines is equivalent to Prelude.lines" $ over chunksSeries $ \chunks ->
-- This only makes sure that the streaming-bytestring lines function
-- matches the Prelude lines function when no carriage returns
-- are present. They are not expected to have the same behavior
-- with dos-style line termination.
let expected = lines $ concat chunks
got = (map B.unpack . sLines . fromChunks) chunks
in
if expected == got
then Right ("" :: String)
else Left (printf "Expected %s; got %s" (show expected) (show got) :: String)
, testProperty "lines recognizes DOS line endings" $ over strSeries $ \str ->
sLines (Q8.string $ unix2dos str) == sLines (Q8.string str)
, testProperty "lines recognizes DOS line endings with tiny chunks" $ over strSeries $ \str ->
sLines (mapM_ Q8.singleton $ unix2dos str) == sLines (mapM_ Q8.singleton str)
, testProperty "lineSplit does not create null chunks (LF)" $ over ((,) <$> nats <~> strSeries) $ \(n,str) ->
noNullChunks (Q8.lineSplit n (fromString str))
, testProperty "lineSplit does not create null chunks (CRLF)" $ over ((,) <$> nats <~> strSeriesCrlf) $ \(n,str) ->
noNullChunks (Q8.lineSplit n (fromString str))
, testProperty "concat after lineSplit round trips (LF)" $ over ((,) <$> nats <~> strSeries) $ \(n,str) ->
unpackToString (Q8.concat (Q8.lineSplit n (fromString str))) == str
, testProperty "concat after lineSplit round trips (CRLF)" $ over ((,) <$> nats <~> strSeriesCrlf) $ \(n,str) ->
unpackToString (Q8.concat (Q8.lineSplit n (fromString str))) == str
, testProperty "'for' is equivalent to the one in streaming" $ over chunksSeries $ \ss ->
let doubleStream b = S.each [b, b]
doubleByteStream b = Q.chunk b *> Q.chunk b
in unpackToString (Q.fromChunks (S.for (Q.toChunks (fromChunks ss)) doubleStream))
== unpackToString (Q.for (fromChunks ss) doubleByteStream)
]
, testGroup "Unit Tests"
[ testCase "hGetContents: Handle stays open" handleIsOpen
, testCase "group(By): Don't crash" groupCrash
, testCase "group: Char order" groupCharOrder
, testCase "groupBy: Char order" groupByCharOrder
, testCase "findIndexOrEnd" goodFindIndex
, testCase "Stream Interop" firstI
, testCase "readInt" readIntCases
, testCase "toLazy_: empty chunks" emptyChunks
]
]