interruptible/test/Test.hs

module Test (tests) where

import Distribution.TestSuite
import System.IO.Error

import Control.Monad.Trans.Either
import Control.Monad.Trans.State
import Data.Either.Combinators
import Control.Monad.Trans.Interruptible
import Control.Monad.IO.Class
import Control.Monad.Trans.SafeIO

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,
  simpleTest "safeIO" tSafeIO,
  simpleTest "safeCL" tSafeCT
  ]

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 <- intercalateFold 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 <- intercalateFold 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

newtype Txt = Txt String
instance IOErrorDerivation Txt where
  coerceIOError = Txt . show

tSafeIO :: IO Progress
tSafeIO = do
  let msg = "test"
      err = show . userError $ msg
  r <- runEitherT (safeIO . ioError . userError $ msg)
  case r of
    Left (Txt msg') -> Finished <$> if err == msg' then return Pass else return . Fail $ "Wrong error: " ++ msg'
    Right _ -> return . Finished . Fail $ "Throwing error didn't create an error!"

tSafeCT :: IO Progress
tSafeCT = do
  let msg = "test"
      err = show . userError $ msg
  r <- fst <$> runStateT (runEitherT (safeCT . stateError $ msg)) ()
  case r of
    Left (Txt msg') -> Finished <$> if err == msg' then return Pass else return . Fail $ "Wrong error: " ++ msg'
    Right _ -> return . Finished . Fail $ "Throwing error didn't create an error!"
  where
    stateError :: String -> StateT () IO ()
    stateError = liftIO . ioError . userError