{-# LANGUAGE Rank2Types #-} -------------------------------------------------------------------- -- | -- Module : System.IO.Lazy.Input.Tests -- Copyright : (c) Nicolas Pouillard 2009 -- License : BSD3 -- -- Maintainer : Nicolas Pouillard -- 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 ((!>>=), (=< 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"))