safe-lazy-io-0.1: System/IO/Lazy/Input/Tests.hs
{-# LANGUAGE Rank2Types #-}
--------------------------------------------------------------------
-- |
-- Module : System.IO.Lazy.Input.Tests
-- Copyright : (c) Nicolas Pouillard 2009
-- License : BSD3
--
-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------
module System.IO.Lazy.Input.Tests where
import Prelude hiding (zipWith)
import qualified Data.List as L
import qualified System.IO as IO
import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Parallel.Strategies (NFData(..))
import Control.Applicative
import Control.Monad
import Data.IORef
import System.IO.Strict (SIO, return')
import qualified System.IO.Strict as SIO
import qualified System.IO.Strict.Internals as SIO
import qualified System.IO.Lazy.Input as LI
import qualified System.IO.Lazy.Input.Extra as LI
import System.IO.Lazy.Input.Internals (LI(..), Finalized(..), chanFromList)
import System.IO.Lazy.Input.Extra ((!>>=), (=<<!), ap')
import System.IO.Lazy.Input (pureLI)
import Debug.Trace (trace)
harness :: LI [a] -> LI [a]
harness (LI start) = LI $ do isOpenRef <- newIORef True
xs0 `Finally` release <- start
let go [] = return []
go (x:xs) = do isOpen <- readIORef isOpenRef
unless isOpen $ fail msg
xs' <- unsafeInterleaveIO $ go xs
return $ x : xs'
msg = "System.IO.Lazy.Input.harness: try to read a closed input"
xs0' <- unsafeInterleaveIO $ go xs0
return $ xs0' `Finally` (release >> writeIORef isOpenRef False)
wrongInterleave :: LI [sa] -> LI [sa] -> LI [sa]
wrongInterleave (LI startA) (LI startB) = LI $ do
xs0 `Finally` releaseA <- startA
ys0 `Finally` releaseB <- startB
lazyReleaseA <- unsafeInterleaveIO releaseA
lazyReleaseB <- unsafeInterleaveIO releaseB
let loopLeft (x:xs) ys = x : loopRight xs ys
loopLeft [] ys = lazyReleaseA `seq` ys
loopRight xs (y:ys) = y : loopLeft xs ys
loopRight xs [] = lazyReleaseB `seq` xs
return $ loopLeft xs0 ys0 `Finally` (lazyReleaseA `seq` lazyReleaseB `seq` return ())
wrongZipWith :: (sa -> sb -> c) -> LI [sa] -> LI [sb] -> LI [c]
wrongZipWith f (LI startA) (LI startB) = LI $ do
xs `Finally` releaseA <- startA
ys `Finally` releaseB <- startB
return $ L.zipWith f xs ys `Finally` (releaseA >> releaseB)
wrongLift2 :: (NFData sc) => (a -> b -> sc) -> LI a -> LI b -> LI sc
wrongLift2 f (LI startA) (LI startB) = LI $ do
x `Finally` releaseA <- startA
y `Finally` releaseB <- startB
let r = f x y
return $ (rnf r `seq` r) `Finally` (releaseA >> releaseB)
wrongAp :: LI (a -> b) -> LI a -> LI b
wrongAp (LI startF) (LI startArg) = LI $ do
f `Finally` releaseF <- startF
arg `Finally` releaseArg <- startArg
return $ f arg `Finally` (releaseF >> releaseArg)
infixl 4 `wrongAp`
{- does not compose well since it cannot returns functions
ap' :: (NFData sb) => LI (a -> sb) -> LI a -> LI sb
ap' (LI startF) (LI startArg) = LI $ do
f `Finally` releaseF <- startF
arg `Finally` releaseArg <- startArg
let r = f arg
rnf r `seq` (releaseF >> releaseArg)
return $ r `Finally` return ()
infixl 4 `ap'`
-}
wrongBind :: LI a -> (a -> LI b) -> LI b
LI startA `wrongBind` f =
LI $ do a `Finally` releaseA <- startA
r `Finally` releaseR <- startLI $ f a
return $ r `Finally` (releaseA >> releaseR)
wrongRun :: NFData a => LI a -> IO a
wrongRun (LI start) = do r `Finally` release <- start
release
return' r
wrongRun' :: NFData a => LI (SIO a) -> IO a
wrongRun' (LI start) = do f `Finally` release <- start
r <- SIO.rawRun f
release
return' r
shallowed :: [a] -> [a]
shallowed model = map (model!!) [0..]
wrongAppend :: NFData sa => LI [sa] -> LI [sa] -> LI [sa]
wrongAppend (LI startA) (LI startB) = LI $ do
xs `Finally` releaseA <- startA
~(ys `Finally` releaseB) <- unsafeInterleaveIO $ releaseA >> startB
return $ (map (\x->rnf x `seq` x) xs ++ ys) `Finally` releaseB
veryWrongAppend :: LI [a] -> LI [a] -> LI [a]
veryWrongAppend (LI startA) (LI startB) = LI $ do
xs `Finally` releaseA <- startA
~(ys `Finally` releaseB) <- unsafeInterleaveIO $ releaseA >> startB
return $ (xs ++ ys) `Finally` releaseB
testAppend :: (forall sa . NFData sa => LI [sa] -> LI [sa] -> LI [sa]) -> IO Bool
testAppend appe = do ch <- chanFromList [1,(2::Int)]
let mxs = take 2 <$> harness (LI.getChanContents ch)
(==[[4],[3],[1,2]]) <$> LI.run (reverse <$> appe ((:[[3]]) <$> mxs) (pureLI [[4]]))
test :: ([Int] -> [Int]) -> (([Int] -> [Int] -> Int) -> LI [Int] -> LI [Int] -> LI Int) -> IO Bool
test rewrap tested = (==) <$> g f1 <*> g f2
where f1 x y = x `seq` y `seq` x - y
f2 x y = y `seq` x `seq` x - y
g f = do ch <- chanFromList [1,2]
let mxs = rewrap <$> harness (shallowed <$> LI.getChanContents ch)
LI.run $ tested (\ a b -> f (head a) (head b)) mxs mxs
runTests :: IO ()
runTests = do
assertIO "lift2ForceFirst" $ test (take 1) LI.lift2ForceFirst
assertIO "lift2ForceSecond" $ test (take 1) LI.lift2ForceSecond
assertIO "lift2ForceBoth" $ test (take 1) LI.lift2ForceBoth
assertIOwrong "wrongLift2" $ test id wrongLift2
assertIO "lift2MayForceFirst" $ test (take 1) LI.lift2MayForceFirst
assertIO "zipWith" $ test (take 1) (wrapZipWith LI.zipWith)
assertIOwrong "wrongZipWith" $ test id (wrapZipWith wrongZipWith)
assertIOwrong "wrongInterleave" $ test id (wrapInterleave wrongInterleave)
assertIO "interleave" $ test (take 1) (wrapInterleave LI.interleave)
assertIO "ap'" $ test (take 1) (\f x y -> f <$> x `ap'` y)
assertIOwrong "wrongAp" $ test id (\f x y -> f <$> x `wrongAp` y)
assertIO "!>>=" $ test (take 1) (\f mx my -> mx !>>= \x-> my !>>= \y-> pureLI (f x y))
assertIOwrong "wrongBind" $ test (take 1) (\f mx my -> mx `wrongBind` \x-> my `wrongBind` \y-> pureLI (f x y))
assertIO "wrongRun'/return'" $ testHarness wrongRun' (return' <$>)
assertIOwrong "wrongRun'/return" $ testHarness wrongRun' (return <$>)
assertIO "LI.append" $ test (take 1) (wrapAppend LI.append)
assertIOwrong "veryWrongAppend" $ test (take 1) (wrapAppend veryWrongAppend)
assertIOwrong "wrongAppend" $ test (take 1) (wrapAppend wrongAppend)
assertIO "testAppend LI.append" $ testAppend LI.append
assertIOwrong "testAppend wrongAppend" $ testAppend wrongAppend
assertIOwrong "testAppend veryWrongAppend" $ testAppend veryWrongAppend
testUnused "id" id
testUnused "LI.append" $ (\i -> take 3 <$> (pureLI "123" `LI.append` i))
where
assertIOgen pass fail' name mb = do b <- mb `catch` (\e -> trace (show e) (return False))
putStr (name ++ ": ")
IO.hFlush IO.stdout
putStrLn (if b then pass else fail')
assertIO = assertIOgen (green "PASS") (red "FAIL")
assertIOwrong = assertIOgen (red "PASS (not expected)") (green "FAIL (as expected)")
green x = "\027[K\027[32m" ++ x ++ "\027[0m"
red x = "\027[K\027[31m" ++ x ++ "\027[0m"
wrapZipWith zipW f xs ys = uncurry f . head <$> zipW (,) ((:[]) <$> xs) ((:[]) <$> ys)
wrapInterleave inte f xs ys = let g [a, b] = f a b in g <$> inte ((:[]) <$> xs) ((:[]) <$> ys)
wrapAppend appe f xs ys = let g [a, b] = f [a] [b] in g <$> appe xs ys
testEq ref comp = (==ref) <$> comp
testHarness runner f = testEq [1::Int ..10] $ runner (f $ harness (pureLI [1..10]))
testUnused name f =
assertIOwrong ("testUnused " ++ name) $ LI.run (const True <$> f (LI.readFile "DOESNOTEXISTS"))