Test.hs

{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
{-# LANGUAGE TypeOperators, DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

module Control.Eff.Exception.Test (testGroups) where

import Test.HUnit hiding (State)
import Control.Eff
import Control.Eff.Exception
import Control.Eff.Lift
import Control.Eff.Writer.Strict
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Utils

import Test.Framework.TH
import Test.Framework.Providers.HUnit

testGroups = [ $(testGroupGenerator) ]

-- The type is inferred
-- et1 :: Eff r Int
et1 = return 1 `add` return 2

case_Exception1_et1 :: Assertion
case_Exception1_et1 = 3 @=? (run et1)

-- The type is inferred
-- et2 :: Member (Exc Int) r => Eff r Int
et2 = return 1 `add` throwError (2::Int)

-- The following won't type: unhandled exception!
-- ex2rw = run et2
{-
    Could not deduce (Data.OpenUnion.FindElem (Exc Int) '[])
      arising from a use of `et2'
-}

case_Exception1_et21 :: Assertion
case_Exception1_et21 = (Left (2::Int)) @=?
  (run et21)
  where
    -- The inferred type shows that ex21 is now pure
    -- et21 :: Eff r (Either Int Int)

    et21 = runError et2

-- Implementing the operator <|> from Alternative:
--  a <|> b does
--   -- tries a, and if succeeds, returns its result
--   -- otherwise, tries b, and if succeeds, returns its result
--   -- otherwise, throws mappend of exceptions of a and b

-- We use SetMember in the signature rather than Member to
-- ensure that the computation throws only one type of exceptions.
-- Otherwise, this construction is not very useful.
alttry :: forall e r a. (Monoid e, SetMember Exc (Exc e) r) =>
          Eff r a -> Eff r a -> Eff r a
alttry ma mb =
  catchError ma $ \ea ->
  catchError mb $ \eb -> throwError (mappend (ea::e) eb)

case_Exception1_alttry :: Assertion
case_Exception1_alttry =
  [Right 10,Right 10,Right 10,Left "bummer1bummer2"] @=?
  [
  run . runError $
     (return 1 `add` throwError "bummer1") `alttry`
     (return 10),
  run . runError $
     (return 10) `alttry`
     (return 1 `add` throwError "bummer2"),
  run . runError $
     (return 10) `alttry` return 20,
  run . runError $
     (return 1 `add` throwError "bummer1") `alttry`
     (return 1 `add` throwError "bummer2")
     ]

case_Failure1_Effect :: Assertion
case_Failure1_Effect =
  let go :: Eff (Exc () ': Writer Int ': '[]) Int
         -> Int
      go = snd . run . runWriter (+) 0 . ignoreFail
      ret = go $ do
        tell (1 :: Int)
        tell (2 :: Int)
        tell (3 :: Int)
        () <- die
        tell (4 :: Int)
        return 5
   in assertEqual "Fail should stop writing" 6 ret

case_Exception1_monadBaseControl :: Assertion
case_Exception1_monadBaseControl =
    runLift (runError act) @=? Just (Left "Fail")
  where
    act = doThing $ do _ <- throwError "Fail"
                       return "Success"