{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS -fno-warn-missing-signatures #-}
import Control.Exception (ErrorCall, catch)
import Data.Typeable

import Test.Framework (defaultMain)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.Framework.TH

import Test.HUnit hiding (State)
import Test.QuickCheck

import Control.Eff
import Data.OpenUnion
import qualified Control.Eff.Reader.Lazy as LazyR
import qualified Control.Eff.Reader.Strict as StrictR
import qualified Control.Eff.Writer.Lazy as LazyW
import qualified Control.Eff.Writer.Strict as StrictW
import qualified Control.Eff.State.Strict as StrictS
import qualified Control.Eff.State.Lazy as LazyS
import qualified Control.Eff.State.LazyState as LazierS
import Control.Eff.Exception
import Control.Eff.Choose as Choose
import Control.Eff.NdetEff
import Control.Monad (liftM2, msum, guard, mzero, mplus)
import Data.Monoid

import Control.Eff.Example as Eg
import Control.Eff.Fresh
import Control.Eff.Lift
import Control.Eff.Operational as Op
import Control.Eff.Operational.Example as Op.Eg
import Control.Eff.Trace
import Control.Eff.Coroutine
import Control.Eff.Cut

-- {{{ utils: TODO: move them out

import GHC.IO.Handle
import System.IO
import System.Directory

-- | capture stdout
-- [[https://stackoverflow.com/a/9664017][source]]
catchOutput :: IO a -> IO (a, String)
catchOutput f = do
  tmpd <- getTemporaryDirectory
  (tmpf, tmph) <- openTempFile tmpd "haskell_stdout"
  stdout_dup <- hDuplicate stdout
  hDuplicateTo tmph stdout
  hClose tmph
  fVal <- f
  hDuplicateTo stdout_dup stdout
  str <- readFile tmpf
  removeFile tmpf
  return (fVal, str)

showLn :: Show a => a -> String
showLn x = unlines $ [show x]

showLines :: Show a => [a] -> String
showLines xs = unlines $ map show xs

withError :: a -> ErrorCall -> a
withError a _ = a

assertUndefined :: a -> Assertion
assertUndefined a = catch (seq a $ assertFailure "") (withError $ return ())

assertNoUndefined :: a -> Assertion
assertNoUndefined a = catch (seq a $ return ()) (withError $ assertFailure "")

allEqual :: Eq a => [a] -> Bool
allEqual = all (uncurry (==)) . pairs
  where
    pairs l = zip l $ tail l

safeLast [] = Nothing
safeLast l = Just $ last l

-- }}}

main :: IO ()
main = $(defaultMainGenerator)

-- {{{ Documentation example

prop_Documentation_example :: [Integer] -> Property
prop_Documentation_example l = let
  ((), total1) = run $ LazyS.runState (Eg.sumAll l) 0
  ((), last1) = run $ LazyW.runLastWriter $ Eg.writeAll l
  (((), last2), total2) = run $ LazyS.runState (LazyW.runLastWriter (Eg.writeAndAdd l)) 0
  (((), total3), last3) = run $ LazyW.runLastWriter $ LazyS.runState (Eg.writeAndAdd l) 0
  in
   allEqual [safeLast l, last1, last2, last3]
   .&&. allEqual [sum l, total1, total2, total3]

-- }}}

-- {{{ Reader

add :: Monad m => m Int -> m Int -> m Int
add = liftM2 (+)
t1 = LazyR.ask `add` return (1::Int)

case_Lazy1_Reader_t1 :: Assertion
case_Lazy1_Reader_t1 = let
  t1' = do v <- LazyR.ask; return (v + 1 :: Int)
  t1r = LazyR.runReader t1 (10::Int)
  in
    -- 'LazyR.run t1' should result in type-error
    11 @=? (run t1r)

t2 = do
  v1 <- LazyR.ask
  v2 <- LazyR.ask
  return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float))


case_Lazy1_Reader_t2 :: Assertion
case_Lazy1_Reader_t2 = let
  t2r = LazyR.runReader t2 (10::Int)
  t2rr = flip LazyR.runReader (20::Float) . flip LazyR.runReader (10::Int) $ t2
  in
    33.0 @=? (run t2rr)

-- The opposite order of layers
{- If we mess up, we get an error
t2rrr1' = run $ runReader (runReader t2 (20::Float)) (10::Float)
    No instance for (Member (Reader Int) [])
      arising from a use of `t2'
-}
case_Lazy1_Reader_t2' :: Assertion
case_Lazy1_Reader_t2' = 33.0 @=?
  (run $ LazyR.runReader (LazyR.runReader t2 (20::Float)) (10::Int))


case_Lazy1_Reader_t3 :: Assertion
case_Lazy1_Reader_t3 = let
  t3 = t1 `add` LazyR.local (+ (10::Int)) t1
  in
    212 @=? (run $ LazyR.runReader t3 (100::Int))

-- The following example demonstrates true interleaving of Reader Int
-- and Reader Float layers
{-
t4
  :: (Member (Reader Int) r, Member (Reader Float) r) =>
     () -> Eff r Float
-}
t4 = liftM2 (+) (LazyR.local (+ (10::Int)) t2)
                (LazyR.local (+ (30::Float)) t2)

case_Lazy1_Reader_t4 :: Assertion
case_Lazy1_Reader_t4 = 106.0 @=?
  (run $ LazyR.runReader (LazyR.runReader t4 (20::Float)) (10::Int))

-- The opposite order of layers gives the same result
case_Lazy1_Reader_t4' :: Assertion
case_Lazy1_Reader_t4' = 106.0 @=?
  (run $ LazyR.runReader (LazyR.runReader t4 (20::Float)) (10::Int))

-- Map an effectful function
case_Lazy1_Reader_tmap :: Assertion
case_Lazy1_Reader_tmap = let
  tmap = mapM f [1..5]
  in
    ([11,12,13,14,15] :: [Int]) @=?
    (run $ LazyR.runReader tmap (10::Int))
  where
    f x = LazyR.ask `add` return x

-- {{{ Reader.runReader

case_Lazy1_Reader_runReader :: Assertion
case_Lazy1_Reader_runReader = let
  e = run $ LazyR.runReader voidReader (undefined :: ())
  in
   assertNoUndefined (e :: ())
  where
    voidReader = do
        _ <- (LazyR.ask :: Eff '[LazyR.Reader ()] ())
        return ()

case_Strict1_Reader_runReader :: Assertion
case_Strict1_Reader_runReader = let
  e = run $ StrictR.runReader voidReader (undefined :: ())
  in
   assertUndefined (e :: ())
  where
    voidReader = do
        _ <- (StrictR.ask :: Eff '[StrictR.Reader ()] ())
        return ()

-- }}}

-- }}}

-- {{{ State.runState

-- {{{ Lazy

case_Lazy1_State_runState :: Assertion
case_Lazy1_State_runState = let
  (r, ()) = run
            $ flip LazyS.runState undefined
            $ getVoid
            >> putVoid undefined
            >> putVoid ()
  in
   assertNoUndefined r
  where
    getVoid :: Eff '[LazyS.State ()] ()
    getVoid = LazyS.get

    putVoid :: () -> Eff '[LazyS.State ()] ()
    putVoid = LazyS.put

-- }}}

-- {{{ Strict1

case_Strict1_State_runState :: Assertion
case_Strict1_State_runState = let
  (r, ()) = run
            $ (flip StrictS.runState) undefined
            $ getVoid
            >> putVoid undefined
            >> putVoid ()
  in
   assertUndefined r
  where
    getVoid :: Eff '[StrictS.State ()] ()
    getVoid = StrictS.get

    putVoid :: () -> Eff '[StrictS.State ()] ()
    putVoid = StrictS.put

case_Strict1_State_ts1 :: Assertion
case_Strict1_State_ts1 = (10,10) @=? (run (StrictS.runState ts1 (0::Int)))
  where
    ts1 = do
      StrictS.put (10 ::Int)
      x <- StrictS.get
      return (x::Int)

case_Strict1_State_ts11 :: Assertion
case_Strict1_State_ts11 =
  (10,10) @=? (run (StrictS.runStateR ts11 (0::Int)))
  where
    ts11 = do
      StrictW.tell (10 ::Int)
      x <- StrictR.ask
      return (x::Int)

case_Strict1_State_ts2 :: Assertion
case_Strict1_State_ts2 = (30::Int,20::Int) @=?
  (run (StrictS.runState ts2 (0::Int)))
  where
    ts2 = do
      StrictS.put (10::Int)
      x <- StrictS.get
      StrictS.put (20::Int)
      y <- StrictS.get
      return (x+y)

case_Strict1_State_ts21 :: Assertion
case_Strict1_State_ts21 = (30::Int,20::Int) @=?
  (run (StrictS.runStateR ts21 (0::Int)))
  where
    ts21 = do
      StrictW.tell (10::Int)
      x <- StrictR.ask
      StrictW.tell (20::Int)
      y <- StrictR.ask
      return (x+y)

tes1 :: (Member (StrictS.State Int) r
        , Member (Exc [Char]) r) => Eff r b
tes1 = do
  incr
  throwExc "exc"
  where
    incr = StrictS.get >>= StrictS.put . (+ (1::Int))

case_Strict1_State_ter1 :: Assertion
case_Strict1_State_ter1 = (Left "exc" :: Either String Int,2) @=?
  (run $ StrictS.runState (runExc tes1) (1::Int))

case_Strict1_State_ter2 :: Assertion
case_Strict1_State_ter2 = (Left "exc" :: Either String (Int,Int)) @=?
  (run $ runExc (StrictS.runState tes1 (1::Int)))

teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char]
teCatch m = catchExc (m >> return "done") (\e -> return (e::String))

case_Strict1_State_ter3 :: Assertion
case_Strict1_State_ter3 = (Right "exc" :: Either String String,2) @=?
  (run $ StrictS.runState (runExc (teCatch tes1)) (1::Int))

case_Strict1_State_ter4 :: Assertion
case_Strict1_State_ter4 = (Right ("exc",2) :: Either String (String,Int)) @=?
  (run $ runExc (StrictS.runState (teCatch tes1) (1::Int)))

-- }}}

-- }}}

-- {{{ Writer

addGet :: Member (LazyR.Reader Int) r  => Int -> Eff r Int
addGet x = LazyR.ask >>= \i -> return (i+x)

addN n = foldl (>>>) return (replicate n addGet) 0
 where f >>> g = (>>= g) . f

case_Lazy1_Writer_rdwr :: Assertion
case_Lazy1_Writer_rdwr = (10, ["begin", "end"]) @=?
  (run . (`LazyR.runReader` (1::Int)) . LazyW.runListWriter $ rdwr)
  where
    rdwr = do
      LazyW.tell "begin"
      r <- addN 10
      LazyW.tell "end"
      return r

-- {{{ Writer.censor

prop_Lazy1_Writer_censor :: [Integer] -> Property
prop_Lazy1_Writer_censor l =
  property
  $ listE (mapM_ (LazyW.tell . inc) l) == listE (LazyW.censor inc $ mapM_ LazyW.tell l)
  where
    inc :: Integer -> Integer
    inc = (+1)

    listE :: Eff '[LazyW.Writer Integer] () -> [Integer]
    listE = snd . run . LazyW.runListWriter

-- }}}

-- {{{ Writer.runFirstWriter

case_Lazy1_Writer_runFirstWriter :: Assertion
case_Lazy1_Writer_runFirstWriter = let
  ((), Just m) = run $ LazyW.runFirstWriter $ mapM_ LazyW.tell [(), undefined]
  in
   assertNoUndefined (m :: ())

-- }}}

-- {{{ Writer.runLastWriter

case_Lazy1_Writer_runLastWriter :: Assertion
case_Lazy1_Writer_runLastWriter = let
  ((), Just m) = run $ LazyW.runLastWriter $ mapM_ LazyW.tell [undefined, ()]
  in
   assertNoUndefined (m :: ())

case_Strict1_Writer_runLastWriter :: Assertion
case_Strict1_Writer_runLastWriter = let
  ((), Just m) = run $ StrictW.runLastWriter $ mapM_ StrictW.tell [undefined, ()]
  in
   assertUndefined (m :: ())

-- }}}

-- }}}

-- {{{ Exception

-- 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` throwExc (2::Int)

-- The following won't type: unhandled exception!
-- ex2rw = run et2
{-
    Could not deduce (Data.OpenUnion51.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 = runExc et2

-- {{{ TooBig example from paper

-- The example from the paper
newtype TooBig = TooBig Int deriving (Eq, Show)
-- The type is inferred
ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
ex2 m = do
  v <- m
  if v > 5 then throwExc (TooBig v)
     else return v

-- specialization to tell the type of the exception
runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a)
runErrBig = runExc

case_Exception1_ex2r :: Assertion
case_Exception1_ex2r = (Right 5) @=? (run ex2r)
  where
    ex2r = LazyR.runReader (runErrBig (ex2 LazyR.ask)) (5::Int)

case_Exception1_ex2r1 :: Assertion
case_Exception1_ex2r1 = (Left (TooBig 7)) @=? (run ex2r1)
  where
    ex2r1 = LazyR.runReader (runErrBig (ex2 LazyR.ask)) (7::Int)

-- Different order of handlers (layers)
case_Exception1_ex2r2 :: Assertion
case_Exception1_ex2r2 = (Left (TooBig 7)) @=? (run ex2r2)
  where
    ex2r2 = runErrBig (LazyR.runReader (ex2 LazyR.ask) (7::Int))

-- }}}

-- {{{ Alternative

-- 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 =
  catchExc ma $ \ea ->
  catchExc mb $ \eb -> throwExc (mappend (ea::e) eb)

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

-- }}}

-- {{{ Eff Failure

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

-- }}}

-- }}}

-- {{{ Choose

case_Choose1_exc11 :: Assertion
case_Choose1_exc11 = [2,3] @=? (run exc11)
  where
    exc11 = Choose.makeChoice exc1
    exc1 = return 1 `add` Choose.choose [1,2]

case_Choose_ex2 :: Assertion
case_Choose_ex2 =
  let ex2_1 = run . makeChoice . runErrBig $ ex2 (Choose.choose [5,7,1])
      ex2_2 = run . runErrBig . makeChoice $ ex2 (Choose.choose [5,7,1])
  in
    assertEqual "Choose: Combining exceptions and non-determinism: ex2_1"
    expected1 ex2_1
    >> assertEqual "Choose: Combining exceptions and non-determinism: ex2_2"
    expected2 ex2_2
  where
    expected1 = [Right 5,Left (TooBig 7),Right 1]
    expected2 = Left (TooBig 7)

case_Choose_exRec :: Assertion
case_Choose_exRec =
  let exRec_1 = run . runErrBig . makeChoice $ exRec (ex2 (Choose.choose [5,7,1]))
      exRec_2 = run . makeChoice . runErrBig $ exRec (ex2 (Choose.choose [5,7,1]))
      exRec_3 = run . runErrBig . makeChoice $ exRec (ex2 (Choose.choose [5,7,11,1]))
  in
    assertEqual "Choose: error recovery: exRec_1" expected1 exRec_1
    >> assertEqual "Choose: error recovery: exRec_2" expected2 exRec_2
    >> assertEqual "Choose: error recovery: exRec_1" expected3 exRec_3
  where
    expected1 = Right [5,7,1]
    expected2 = [Right 5,Right 7,Right 1]
    expected3 = Left (TooBig 11)
    -- Errror recovery part
    -- The code is the same as in transf1.hs. The inferred signatures differ
    -- Was: exRec :: MonadError TooBig m => m Int -> m Int
    -- exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
    exRec m = catchExc m handler
      where handler (TooBig n) | n <= 7 = return n
            handler e = throwExc e

-- }}}

-- {{{ NdetEff

case_NdetEff_testCA :: Assertion
case_NdetEff_testCA = [2, 4..10] @=? (run $ makeChoiceA testCA)
  where
    testCA :: (Integral a) => Eff (NdetEff ': r) a
    testCA = do
      i <- msum . fmap return $ [1..10]
      guard (i `mod` 2 == 0)
      return i

case_NdetEff_ifte :: Assertion
case_NdetEff_ifte =
  let primes = ifte_test_run
  in
    assertEqual "NdetEff: test ifte using primes"
    [2,3,5,7,11,13,17,19,23,29] primes
  where
    ifte_test = do
      n <- gen
      ifte (do
               d <- gen
               guard $ d < n && n `mod` d == 0
               -- _ <- trace ("d: " ++ show d) (return ())
           )
        (\_ -> mzero)
        (return n)
        where gen = msum . fmap return $ [2..30]

    ifte_test_run :: [Int]
    ifte_test_run = run . makeChoiceA $ ifte_test


-- called reflect in the LogicT paper
case_NdetEff_reflect :: Assertion
case_NdetEff_reflect =
  let tsplitr10 = run $ StrictW.runListWriter $ makeChoiceA tsplit
      tsplitr11 = run $ StrictW.runListWriter $ makeChoiceA (msplit tsplit >>= unmsplit)
      tsplitr20 = run $ makeChoiceA $ StrictW.runListWriter tsplit
      tsplitr21 = run $ makeChoiceA $ StrictW.runListWriter (msplit tsplit >>= unmsplit)
  in
    assertEqual "tsplitr10" expected1 tsplitr10
    >> assertEqual "tsplitr11" expected1 tsplitr11
    >> assertEqual "tsplitr20" expected2 tsplitr20
    >> assertEqual "tsplitr21" expected21 tsplitr21
  where
    expected1 = ([1, 2],["begin", "end"])
    expected2 = [(1, ["begin"]), (2, ["end"])]
    expected21 = [(1, ["begin"]), (2, ["begin", "end"])]

    unmsplit :: Member NdetEff r => (Maybe (a, Eff r a)) -> Eff r a
    unmsplit Nothing      = mzero
    unmsplit (Just (a,m)) = return a `mplus` m

    tsplit =
      (StrictW.tell "begin" >> return 1) `mplus`
      (StrictW.tell "end"   >> return 2)

-- }}}

-- {{{ test Lift building

-- | 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, SetMember Lift (Lift m) r) => Eff r ()
    possiblyAmbiguous = lift $ return ()

-- }}}

-- {{{ Nested Eff

prop_NestedEff :: Property
prop_NestedEff = forAll arbitrary (\x -> property (qu x == x))
  where
    qu :: Bool -> Bool
    qu x = run $ StrictR.runReader (readerAp x) readerId

    readerAp :: Bool -> Eff '[StrictR.Reader (Eff '[StrictR.Reader Bool] Bool)] Bool
    readerAp x = do
      f <- StrictR.ask
      return . run $ StrictR.runReader f x

    readerId :: Eff '[StrictR.Reader Bool] Bool
    readerId = do
      x <- StrictR.ask
      return x

-- }}}

-- {{{ Operational Monad

case_Operational_Monad :: Assertion
case_Operational_Monad =
  let comp :: (Member (LazyS.State [String]) r
               , Member (LazyW.Writer String) r)
              => Eff r ()
      comp = Op.runProgram Op.Eg.adventPure Op.Eg.prog
      go = snd . run . LazyW.runMonoidWriter $ LazyS.evalState comp ["foo", "bar"]
  in
   assertEqual
   "Evaluating Operational Monad example"
   (unlines ["getting input...",
             "ok",
             "the input is foo"]) go

-- }}}

-- {{{ Yield

yieldInt :: Member (Yield Int ()) r => Int -> Eff r ()
yieldInt = yield

case_Coroutines_c1 :: Assertion
case_Coroutines_c1 = do
  ((), actual) <- catchOutput c1
  assertEqual
    "Coroutine: Simple coroutines using Eff"
    (unlines ["1", "2", "Done"]) actual
  where
    th1 :: Member (Yield Int ()) r => Eff r ()
    th1 = yieldInt 1 >> yieldInt 2

    c1 = runTrace (loop =<< runC th1)
      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
            loop (Done)    = trace ("Done")

case_Coroutines_c2 :: Assertion
case_Coroutines_c2 = do
  ((), actual1) <- catchOutput c2
  assertEqual "Coroutine: Add dynamic variables"
    (unlines ["10", "10", "Done"]) actual1
  ((), actual2) <- catchOutput c21
  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"
    (unlines ["10", "11", "Done"]) actual2
  where
    -- The code is essentially the same as that in transf.hs (only added
    -- a type specializtion on yield). The inferred signature is different though.
    -- Before it was
    --    th2 :: MonadReader Int m => CoT Int m ()
    -- Now it is more general:
    th2 :: (Member (Yield Int ()) r, Member (StrictR.Reader Int) r) => Eff r ()
    th2 = StrictR.ask >>= yieldInt >> (StrictR.ask >>= yieldInt)

    -- Code is essentially the same as in transf.hs; no liftIO though
    c2 = runTrace $ StrictR.runReader (loop =<< runC th2) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
            loop Done    = trace "Done"

    -- locally changing the dynamic environment for the suspension
    c21 = runTrace $ StrictR.runReader (loop =<< runC th2) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> StrictR.local (+(1::Int)) (k ()) >>= loop
            loop Done    = trace "Done"

case_Coroutines_c3 :: Assertion
case_Coroutines_c3 = do
  ((), actual1) <- catchOutput c3
  assertEqual "Coroutine: two sorts of local rebinding"
    (unlines ["10", "10", "20", "20", "Done"]) actual1
  ((), actual2) <- catchOutput c31
  let expected2 = (unlines ["10", "11", "21", "21", "Done"])
  assertEqual "Coroutine: locally changing the dynamic environment for the suspension"
    expected2 actual2
  ((), actual3) <- catchOutput c4
  assertEqual "Coroutine: abstracting the client computation"
    expected2 actual3
  where
    local = StrictR.local
    ask = StrictR.ask
    runReader = StrictR.runReader

    th3 :: (Member (Yield Int ()) r, Member (StrictR.Reader Int) r) => Eff r ()
    th3 = ay >> ay >> local (+(10::Int)) (ay >> ay)
      where ay = ask >>= yieldInt

    c3 = runTrace $ runReader (loop =<< runC th3) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
            loop Done    = trace "Done"

    -- The desired result: the coroutine shares the dynamic environment with its
    -- parent; however, when the environment is locally rebound, it becomes
    -- private to coroutine.
    c31 = runTrace $ runReader (loop =<< runC th3) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop
            loop Done    = trace "Done"

    -- We now make explicit that the client computation, run by th4,
    -- is abstract. We abstract it out of th4
    c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> local (+(1::Int)) (k ()) >>= loop
            loop Done    = trace "Done"

            -- cl, client, ay are monomorphic bindings
            th4 cl = cl >> local (+(10::Int)) cl
            client = ay >> ay
            ay     = ask >>= yieldInt

case_Corountines_c5 :: Assertion
case_Corountines_c5 = do
  ((), actual) <- catchOutput c5
  let expected = unlines ["10"
                         ,"11"
                         ,"12"
                         ,"18"
                         ,"18"
                         ,"18"
                         ,"29"
                         ,"29"
                         ,"29"
                         ,"29"
                         ,"29"
                         ,"29"
                         ,"Done"
                         ]
  assertEqual "Corountine: Even more dynamic example"
    expected actual
  where
    local = StrictR.local
    ask = StrictR.ask
    runReader = StrictR.runReader

    c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int)
      where loop (Y x k) = trace (show (x::Int)) >> local (\y->x+1) (k ()) >>= loop
            loop Done    = trace "Done"

            -- cl, client, ay are monomorphic bindings
            client = ay >> ay >> ay
            ay     = ask >>= yieldInt

            -- There is no polymorphic recursion here
            th cl = do
              cl
              v <- ask
              (if v > (20::Int) then id else local (+(5::Int))) cl
              if v > (20::Int) then return () else local (+(10::Int)) (th cl)

case_Coroutines_c7 :: Assertion
case_Coroutines_c7 = do
  ((), actual) <- catchOutput c7
  let expected = unlines ["1010"
                         ,"1021"
                         ,"1032"
                         ,"1048"
                         ,"1064"
                         ,"1080"
                         ,"1101"
                         ,"1122"
                         ,"1143"
                         ,"1169"
                         ,"1195"
                         ,"1221"
                         ,"1252"
                         ,"1283"
                         ,"1314"
                         ,"1345"
                         ,"1376"
                         ,"1407"
                         ,"Done"
                         ]
  assertEqual "Coroutine: And even more dynamic example"
    expected actual
  where
    local = StrictR.local
    ask = StrictR.ask
    runReader = StrictR.runReader

    c7 = runTrace $
          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)
     where loop (Y x k) = trace (show (x::Int)) >>
                          local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop
           loop Done    = trace "Done"

           -- cl, client, ay are monomorphic bindings
           client = ay >> ay >> ay
           ay     = ask >>= \x -> ask >>=
                     \y -> yieldInt (x + round (y::Double))

           -- There is no polymorphic recursion here
           th cl = do
             cl
             v <- ask
             (if v > (20::Int) then id else local (+(5::Int))) cl
             if v > (20::Int) then return () else local (+(10::Int)) (th cl)

case_Coroutines_c7' :: Assertion
case_Coroutines_c7' = do
  ((), actual) <- catchOutput c7'
  let expected = unlines ["1010"
                         ,"1021"
                         ,"1032"
                         ,"1048"
                         ,"1048"
                         ,"1048"
                         ,"1069"
                         ,"1090"
                         ,"1111"
                         ,"1137"
                         ,"1137"
                         ,"1137"
                         ,"1168"
                         ,"1199"
                         ,"1230"
                         ,"1261"
                         ,"1292"
                         ,"1323"
                         ,"Done"
                         ]
  assertEqual "Coroutine: And even more dynamic example"
    expected actual
  where
    local = StrictR.local
    ask = StrictR.ask
    runReader = StrictR.runReader

    c7' = runTrace $
          runReader (runReader (loop =<< runC (th client)) (10::Int)) (1000::Double)
     where loop (Y x k) = trace (show (x::Int)) >>
                          local (\y->fromIntegral (x+1)::Double) (k ()) >>= loop
           loop Done    = trace "Done"

           -- cl, client, ay are monomorphic bindings
           client = ay >> ay >> ay
           ay     = ask >>= \x -> ask >>=
                     \y -> yieldInt (x + round (y::Double))

           -- There is no polymorphic recursion here
           th cl = do
             cl
             v <- ask
             (if v > (20::Int) then id else local (+(5::Double))) cl
             if v > (20::Int) then return () else local (+(10::Int)) (th cl)

-- }}}

-- {{{ Lift

case_Lift_tl1r :: Assertion
case_Lift_tl1r = do
  ((), output) <- catchOutput tl1r
  assertEqual "Test tl1r" (showLn input) output
  where
    input = (5::Int)
    -- tl1r :: IO ()
    tl1r = runLift (StrictR.runReader tl1 input)
      where
        tl1 = StrictR.ask >>= \(x::Int) -> lift . print $ x

case_Lift_tMd' :: Assertion
case_Lift_tMd' = do
  actual <- catchOutput tMd'
  let expected = (output, (showLines input))
  assertEqual "Test mapMdebug using Lift" expected actual
  where
    input = [1..5]
    val = (10::Int)
    output = map (+ val) input

    tMd' = runLift $ StrictR.runReader (mapMdebug' f input) val
      where f x = StrictR.ask `add` return x

    -- Re-implemenation of mapMdebug using Lifting
    -- The signature is inferred
    mapMdebug'  :: (Show a, SetMember Lift (Lift 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')

-- }}}

-- {{{ Trace

case_Trace_tdup :: Assertion
case_Trace_tdup = do
  ((), actual) <- catchOutput tdup
  assertEqual "Trace: duplicate layers"
    (unlines ["Asked: 20", "Asked: 10"]) actual
  where
    tdup = runTrace $ StrictR.runReader m (10::Int)
     where
     m = do
         StrictR.runReader tr (20::Int)
         tr
     tr = do
          v <- StrictR.ask
          trace $ "Asked: " ++ show (v::Int)

case_Trace_tMd :: Assertion
case_Trace_tMd = do
  actual <- catchOutput tMd
  assertEqual "Trace: higher-order effectful function"
    (map (+ val) input, unlines $ map (("mapMdebug: " ++) . show) input) actual
  where
    val = (10::Int)
    input = [1..5]
    tMd = runTrace $ StrictR.runReader (mapMdebug f input) val
      where
        f x = StrictR.ask `add` return x

        -- Higher-order effectful function
        -- The inferred type shows that the Trace affect is added to the effects
        -- of r
        mapMdebug:: (Show a, Member Trace r) =>
                    (a -> Eff r b) -> [a] -> Eff r [b]
        mapMdebug f [] = return []
        mapMdebug f (h:t) = do
          trace $ "mapMdebug: " ++ show h
          h' <- f h
          t' <- mapMdebug f t
          return (h':t')

-- }}}

-- {{{ Fresh

case_Fresh_tfresh' :: Assertion
case_Fresh_tfresh' = do
  ((), actual) <- catchOutput tfresh'
  assertEqual "Fresh: test"
    (unlines ["Fresh 0", "Fresh 1"]) actual
  where
    tfresh' = runTrace $ flip runFresh' 0 $ do
      n <- fresh
      trace $ "Fresh " ++ show n
      n <- fresh
      trace $ "Fresh " ++ show n

-- }}}

-- {{{ LazyState

case_LazierState_ex1 :: Assertion
case_LazierState_ex1 =
  let actual = run $ LazierS.runStateLazy 0 lex1
  in
    assertEqual "LazyState: ex1"
    ((), 1::Int) actual
  where
    lex1 = do
      LazierS.onDemand lex1
      LazierS.lput (1::Int)

case_LazierState_ex3 :: Assertion
case_LazierState_ex3 =
  let (x,s) = run $ LazierS.runStateLazy (undefined::[Int]) lex3
  in assertEqual "LazyState: ex3"
     ((),[1,1,1,1,1]) (x,take 5 s)
  where
    lex3 = do
      LazierS.onDemand lex3
      LazierS.lmodify ((1::Int):)

-- a bit more interesting
case_LazierState_ex4 =
  let (x,s) = run $ LazierS.runStateLazy [] lex4
  in assertEqual "LazyState: ex4"
     expect (take 7 $ x,take 5 $ s)
  where
    expect = ([3,2,3,2,3,2,3],[3,2,3,2,3])
    lex4 :: Eff '[LazierS.LazyState [Int]] [Int]
    lex4 = do
      LazierS.lmodify ((0::Int):)
      LazierS.onDemand lex4
      LazierS.lmodify ((1::Int):)
      LazierS.onDemand (LazierS.onDemand lex4 :: Eff '[LazierS.LazyState [Int]] [Int])
      LazierS.lmodify ((2::Int):)
      LazierS.lmodify ((3::Int):)
      LazierS.lget


-- Edward's example plus exceptions
case_LazierState_ex5 :: Assertion
case_LazierState_ex5 =
  let
    -- the annotations below are needed for assertEqual
    ex5Run :: Either [Int] () = fst . run . LazierS.runStateLazy (undefined::[Int]) . runExc $ lex5
    ex51Run :: Either [Int] ((), [Int]) = run . runExc . LazierS.runStateLazy (undefined::[Int]) $ lex5
  in
    assertEqual "LazyState ex5" (Left ones) ex5Run
    >> assertEqual "LazyState ex51" (Left ones) ex51Run
  where
    ones = take 5 $ repeat (1::Int)
    lex31 :: Member (LazierS.LazyState [Int]) r => Eff r ()
    lex31 = do
      LazierS.onDemand (lex31 :: Eff '[LazierS.LazyState [Int]] ())
      LazierS.lmodify ((1::Int):)

    lex5 = do
      lex31
      x <- LazierS.lget
      throwExc ((take 5 x)::[Int])

case_LazierState_st :: Assertion
case_LazierState_st = let
  stF :: ((Int,Int,Int),Int) = run $ LazierS.runStateLazy (0::Int) st
  stB0 :: ((Int,Int,Int),Int) = LazierS.runStateBack0 st
  stB :: ((Int,Int,Int),Int) = LazierS.runStateBack st
  in
    assertEqual "LazyState stF" ((0,1,3),4) stF
    >> assertEqual "LazyState stB0" ((1,2,4),1) stB0
    >> assertEqual "LazyState stB" ((1,2,4),1) stB
  where
    st = do
      x <- LazierS.lget
      LazierS.lput (1::Int)
      LazierS.lput (1::Int)
      y <- LazierS.lget
      LazierS.lput (2::Int)
      LazierS.lput (10::Int)
      LazierS.lput (3::Int)
      z <- LazierS.lget
      LazierS.lput (4::Int)
      return (x,y,z)

case_LazierState_ones :: Assertion
case_LazierState_ones =
  let ones :: [Int] = snd $ LazierS.runStateBack $ do
        s <- LazierS.lget
        LazierS.lput ((1::Int):s)
  in
    assertEqual "LazyState ones" [1,1,1,1,1] (take 5 ones)

-- }}}

-- {{{ Cut

case_Cut_tcut :: Assertion
case_Cut_tcut =
  let tcut1r = run . makeChoice $ call tcut1
      tcut2r = run . makeChoice $ call tcut2
      tcut3r = run . makeChoice $ call tcut3
      tcut4r = run . makeChoice $ call tcut4
  in
    assertEqual "Cut: tcut1" [1,2] tcut1r
    >> assertEqual "Cut: nested call: tcut2" [1,2,5] tcut2r
    >> assertEqual "Cut: nested call: tcut3" [1,2,1,2,5] tcut3r
    >> assertEqual "Cut: nested call: tcut4" [1,2,1,2,5] tcut4r
  where
    -- signature is inferred
    -- tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int
    tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`
            ((cutfalse `mplus'` return 4) `mplus'`
             return 5)
    -- Here we see nested call. It poses no problems...
    tcut2 = return (1::Int) `mplus'`
            call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'`
                  return 4)
            `mplus'` return 5
    tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse)
    tcut4 = call tcut1 `mplus'`  (tcut2 `mplus'` cutfalse)

-- }}}