Test.hs 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115
  1. module Test (tests) where
  2. import Distribution.TestSuite
  3. import System.IO.Error
  4. import Control.Monad.Trans.Either
  5. import Control.Monad.Trans.State
  6. import Data.Either.Combinators
  7. import Control.Monad.Trans.Interruptible
  8. import Control.Monad.IO.Class
  9. import Control.Monad.Trans.SafeIO
  10. simpleTest :: String -> IO Progress -> Test
  11. simpleTest n t =
  12. let test = TestInstance
  13. {run = t',
  14. name = n,
  15. tags = [],
  16. options = [],
  17. setOption = \_ _ -> Right test
  18. }
  19. in Test test
  20. where
  21. t' :: IO Progress
  22. t' = catchIOError t (
  23. \e -> return . Finished . Fail $ "Raised exception: " ++ show e
  24. )
  25. tests :: IO [Test]
  26. tests = return [
  27. simpleTest "resume" tres,
  28. simpleTest "resume2" tres2,
  29. simpleTest "resume3" tres3,
  30. simpleTest "resume4" tres4,
  31. simpleTest "resume5" tres5,
  32. simpleTest "intercalate1" int1,
  33. simpleTest "intercalate5" int5,
  34. simpleTest "safeIO" tSafeIO,
  35. simpleTest "safeCL" tSafeCT
  36. ]
  37. tres :: IO Progress
  38. tres = do
  39. let f = (\x -> return $ x + 1) :: Int -> EitherT () IO Int
  40. r <- resume f (Right 1)
  41. let v = fromRight 0 r
  42. Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  43. tres2 :: IO Progress
  44. tres2 = do
  45. let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () IO) Int
  46. r <- resume2 f (Right . Right $ 1)
  47. let v = fromRight 0 . fromRight (Left ()) $ r
  48. Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  49. tres3 :: IO Progress
  50. tres3 = do
  51. let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () IO)) Int
  52. r <- resume3 f (Right . Right . Right $ 1)
  53. let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) $ r
  54. Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  55. tres4 :: IO Progress
  56. tres4 = do
  57. let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () IO))) Int
  58. r <- resume4 f (Right . Right . Right . Right $ 1)
  59. let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
  60. Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  61. tres5 :: IO Progress
  62. tres5 = do
  63. let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
  64. r <- resume5 f (Right . Right . Right . Right . Right $ 1)
  65. let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
  66. Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
  67. int1 :: IO Progress
  68. int1 = do
  69. let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () IO Int
  70. r <- intercalateWith resume f [1, 2, 3] (map Right [10, 20])
  71. let v = map (fromRight 0) r
  72. Finished <$> if v == [16, 26] then return Pass else return $ Fail $ "Wrong value: " ++ show v
  73. int5 :: IO Progress
  74. int5 = do
  75. let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
  76. r <- intercalateWith resume5 f [1, 2, 3] (map (Right . Right . Right . Right . Right) [10, 20])
  77. let v = map (fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ())) r
  78. Finished <$> if v == [16, 26] then return Pass else return . Fail $ "Wrong value: " ++ show v
  79. newtype Txt = Txt String
  80. instance IOErrorDerivation Txt where
  81. coerceIOError = Txt . show
  82. tSafeIO :: IO Progress
  83. tSafeIO = do
  84. let msg = "test"
  85. err = show . userError $ msg
  86. r <- runEitherT (safeIO . ioError . userError $ msg)
  87. case r of
  88. Left (Txt msg') -> Finished <$> if err == msg' then return Pass else return . Fail $ "Wrong error: " ++ msg'
  89. Right _ -> return . Finished . Fail $ "Throwing error didn't create an error!"
  90. tSafeCT :: IO Progress
  91. tSafeCT = do
  92. let msg = "test"
  93. err = show . userError $ msg
  94. r <- fst <$> runStateT (runEitherT (safeCT . stateError $ msg)) ()
  95. case r of
  96. Left (Txt msg') -> Finished <$> if err == msg' then return Pass else return . Fail $ "Wrong error: " ++ msg'
  97. Right _ -> return . Finished . Fail $ "Throwing error didn't create an error!"
  98. where
  99. stateError :: String -> StateT () IO ()
  100. stateError = liftIO . ioError . userError