content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE NoMonomorphismRestriction #-}
  {-# LANGUAGE TypeOperators, DataKinds #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TypeApplications #-}
  
  module Control.Eff.Test (testGroups) where
  
  import Test.HUnit hiding (State)
  import Test.QuickCheck
  import Control.Eff
  import Control.Eff.Reader.Strict
  import Control.Eff.State.Strict
  import Control.Eff.Exception
  import qualified Control.Exception as Exc
  import Utils
  
  import Test.Framework.TH
  import Test.Framework.Providers.HUnit
  import Test.Framework.Providers.QuickCheck2
  
  testGroups = [ $(testGroupGenerator) ]
  
  prop_NestedEff :: Property
  prop_NestedEff = forAll arbitrary (\x -> property (qu x == x))
    where
      qu :: Bool -> Bool
      qu x = run $ runReader readerId (readerAp x)
  
      readerAp :: Bool -> Eff '[Reader (Eff '[Reader Bool] Bool)] Bool
      readerAp x = do
        f <- ask
        return . run $ runReader x f
  
      readerId :: Eff '[Reader Bool] Bool
      readerId = do
        x <- ask
        return x
  
  -- | Ensure that https://github.com/RobotGymnast/extensible-effects/issues/11 stays resolved.
  case_Lift_building :: Assertion
  case_Lift_building = runLift possiblyAmbiguous
    where
      possiblyAmbiguous :: (Monad m, Lifted m r) => Eff r ()
      possiblyAmbiguous = lift $ return ()
  
  case_Lift_tl1r :: Assertion
  case_Lift_tl1r = do
    ((), output) <- catchOutput tl1r
    assertOutput "Test tl1r" [show input] output
    where
      input = (5::Int)
      -- tl1r :: IO ()
      tl1r = runLift (runReader input tl1)
        where
          tl1 = ask >>= \(x::Int) -> lift . print $ x
  
  case_Lift_tMd' :: Assertion
  case_Lift_tMd' = do
    (actualResult, actualOutput) <- catchOutput tMd'
    let expected = (output, map show input)
    assertEqual "Test mapMdebug using Lift" expected (actualResult, lines actualOutput)
    where
      input = [1..5]
      val = (10::Int)
      output = map (+ val) input
  
      tMd' = runLift $ runReader val $ mapMdebug' f input
        where f x = ask `add` return x
  
      -- Re-implemenation of mapMdebug using Lifting
      -- The signature is inferred
      mapMdebug'  :: (Show a, Lifted IO r) =>
                     (a -> Eff r b) -> [a] -> Eff r [b]
      mapMdebug' _f [] = return []
      mapMdebug' f (h:t) = do
        lift $ print h
        h' <- f h
        t' <- mapMdebug' f t
        return (h':t')
  
  -- tests from <http://okmij.org/ftp/Haskell/misc.html#catch-MonadIO>
  data MyException = MyException String deriving (Show)
  instance Exc.Exception MyException
  
  exfn :: Lifted IO r => Bool -> Eff r Bool
  exfn True = lift . Exc.throw $ (MyException "thrown")
  exfn False = return True
  
  testc m = catchDynE (m >>= return . show) (\ (MyException s) -> return s)
  test1 m = do runLift (tf m True) >>= print; runLift (tf m False) >>= print
  tf m x = runReader (x::Bool) . runState ([]::[String]) $ m
  
  runErrorStr = runError @String
  
  case_catchDynE_test1 :: Assertion
  case_catchDynE_test1 = do
    ((), actual) <- catchOutput $ test1 (testc m)
    let expected = [ "(\"thrown\",[\"begin\"])"
                   , "(\"True\",[\"end\",\"begin\"])"]
    assertOutput "catchDynE: test1: exception shouldn't drop Writer's state"
      expected actual
    where
      -- In CatchMonadIO, the result of tf True is ("thrown",[]) --
      -- that is, an exception will drop the Writer's state, even if that
      -- exception is caught. Here, the state is preserved!
      -- So, this is an advantage over MTL!
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x
        modify ("end":)
        return r
  
  -- Let us use an Error effect instead
  case_catchDynE_test1' :: Assertion
  case_catchDynE_test1' = do
    ((), actual') <- catchOutput $ test1 (runErrorStr (testc m))
    let expected' = [ "(Left \"thrown\",[\"begin\"])"
                    , "(Right \"True\",[\"end\",\"begin\"])"]
    assertOutput "catchDynE: test1': Error shouldn't drop Writer's state"
      expected' actual'
    where
      -- In CatchMonadIO, the result of tf True is ("thrown",[]) --
      -- that is, an exception will drop the Writer's state, even if that
      -- exception is caught. Here, the state is preserved!
      -- So, this is an advantage over MTL!
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x
        modify ("end":)
        return r
  
      exfn True = throwError $ ("thrown")
      exfn False = return True
  -- Now, the behavior of the dynamic Exception and Error effect is consistent.
  -- The state is preserved. Before it wasn't.
  
  case_catchDynE_test2 :: Assertion
  case_catchDynE_test2 = do
    ((), actual) <- catchOutput $ test1 (runErrorStr (testc m))
    let expected = [ "(Left \"thrown\",[\"begin\"])"
                   , "(Right \"True\",[\"end\",\"begin\"])"]
    assertOutput "catchDynE: test2: Error shouldn't drop Writer's state"
      expected actual
    where
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x `catchDynE` (\ (MyException s) -> throwError s)
        modify ("end":)
        return r
  
  -- Full recovery
  case_catchDynE_test2' :: Assertion
  case_catchDynE_test2' = do
    ((), actual) <- catchOutput $ test1 (runErrorStr (testc m))
    let expected = [ "(Right \"False\",[\"end\",\"begin\"])"
                   , "(Right \"True\",[\"end\",\"begin\"])"]
    assertOutput "catchDynE: test2': Fully recover from errors"
      expected actual
    where
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x `catchDynE` (\ (MyException _s) -> return False)
        modify ("end":)
        return r
  
  -- Throwing within a handler
  case_catchDynE_test3 :: Assertion
  case_catchDynE_test3 = do
    ((), actual) <- catchOutput $ test1 (runErrorStr (testc m))
    let expected = [ "(Right \"rethrow:thrown\",[\"begin\"])"
                   , "(Right \"True\",[\"end\",\"begin\"])"]
    assertOutput "catchDynE: test3: Throwing within a handler"
      expected actual
    where
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x `catchDynE` (\ (MyException s) ->
                                   lift . Exc.throw . MyException $
                                   ("rethrow:" ++ s))
        modify ("end":)
        return r
  
  -- Implement the transactional behavior: when the exception is raised,
  -- the state is rolled back to what it existed at the entrance to
  -- the catch block.
  -- This is the ``scoping behavior'' of `Handlers in action'
  case_catchDynE_tran :: Assertion
  case_catchDynE_tran = do
    ((), actual1) <- catchOutput $ test1 m1
    ((), actual2) <- catchOutput $ test1 m2
    let expected1 = ["(\"thrown\",[\"init\"])"
                    ,"(\"True\",[\"end\",\"begin\",\"init\"])"]
    let expected2 = ["(\"thrown\",[\"begin\",\"init\"])"
                    ,"(\"True\",[\"end\",\"begin\",\"init\"])"]
    assertOutput "catchDynE: tran: Transactional behaviour" expected1 actual1
      >> assertOutput "catchDynE: tran: usual behaviour" expected2 actual2
    where
      m1 = do
        modify ("init":)
        testc (transactionState (TxState :: TxState [String]) m)
      m2 = do
        modify ("init":)
        testc m
      m = do
        modify ("begin":)
        x <- ask
        r <- exfn x
        modify ("end":)
        return r
  