interruptible/test/Test.hs

module Test (tests) where

import Distribution.TestSuite
import System.IO.Error

import Control.Monad.Trans.Either
import Data.Either.Combinators
import Control.Monad.Trans.Interruptible

simpleTest :: String -> IO Progress -> Test
simpleTest n t = 
  let test = TestInstance
        {run = t',
         name = n,
         tags = [],
         options = [],
         setOption = \_ _ -> Right test
        }
  in Test test
  where
    t' :: IO Progress
    t' = catchIOError t (
      \e -> return . Finished . Fail $ "Raised exception: " ++ show e
      )

tests :: IO [Test]
tests = return [
  simpleTest "resume" (tres),
  simpleTest "resume2" (tres2),
  simpleTest "resume3" (tres3),
  simpleTest "resume4" (tres4),
  simpleTest "resume5" (tres5),
  simpleTest "intercalate1" (int1),
  simpleTest "intercalate5" (int5)
  ]

tres :: IO Progress
tres = do
  let f = (\x -> return $ x + 1) :: Int -> EitherT () IO Int
  r <- resume f (Right 1)
  let v = fromRight 0 r
  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  
tres2 :: IO Progress
tres2 = do
  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () IO) Int
  r <- resume2 f (Right . Right $ 1)
  let v = fromRight 0 . fromRight (Left ()) $ r
  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  
tres3 :: IO Progress
tres3 = do
  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () IO)) Int
  r <- resume3 f (Right . Right . Right $ 1)
  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) $ r
  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v

tres4 :: IO Progress
tres4 = do
  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () IO))) Int
  r <- resume4 f (Right . Right . Right . Right $ 1)
  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v

tres5 :: IO Progress
tres5 = do
  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
  r <- resume5 f (Right . Right . Right . Right . Right $ 1)
  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v

int1 :: IO Progress
int1 = do
  let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () IO Int
  r <- intercalateWith resume f [1, 2, 3] (map Right [10, 20])
  let v = map (fromRight 0) r
  Finished <$> if v == [16, 26] then return Pass else return $ Fail $ "Wrong value: " ++ show v

int5 :: IO Progress
int5 = do
  let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
  r <- intercalateWith resume5 f [1, 2, 3] (map (Right . Right . Right . Right . Right) [10, 20])
  let v = map (fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ())) r
  Finished <$> if v == [16, 26] then return Pass else return $ Fail $ "Wrong value: " ++ show v