{-# OPTIONS -fglasgow-exts #-}
-- Control operators for delimited continuations
-- (implemented using 2-level CPS)
-- Transformer
module Pugs.Cont.CC_2CPST (
CC, Prompt, SubCont,
runCC,
newPrompt, pushPrompt, -- operations on prompts
letSubCont, pushSubCont, -- operations on subcontinuations
) where
import qualified Pugs.Cont.PromptTR as PromptTR
import Pugs.Cont.SeqTR
import Control.Monad.Trans
----------------------------------------------------------------------
-- Types
newtype Cont m r a b = Cont (a -> MC r m b)
type MetaCont r m a b = Seq (Cont m) r a b
newtype CC r m a = CC (forall b. Cont m r a b -> MC r m b)
newtype MC r m b = MC (forall ans. MetaCont r m b ans -> PromptTR.P r m ans)
type Prompt r a = PromptTR.Prompt r a
type SubCont r m a b = Seq (Cont m) r a b
----------------------------------------------------------------------
instance Monad m => Monad (CC r m) where
return e = CC (\ (Cont k) -> k e)
(CC e1) >>= e2 = CC (\k -> e1 (Cont (\v1 -> let CC c = e2 v1 in c k)))
instance MonadTrans (CC r) where
lift m = CC (\ (Cont k) ->
MC (\mk -> lift (m >>= (\a -> let MC mc = k a
in PromptTR.runP (mc mk)))))
instance (MonadIO m) => MonadIO (CC r m) where
liftIO = lift . liftIO
-- The previous equation was derived to guarantee the law
-- that runCC (lift m) === m
-- Indeed, runCC (lift m) reduces to the following
--runCC ce = PromptTR.runP (lift (m >>= (\a -> PromptTR.runP (return a))))
runC :: Monad m => (Cont m r a a -> MC r m a) -> MC r m a
runC e = e (Cont (\v -> MC (\mk -> appmk mk v)))
runCC :: Monad m => (forall r. CC r m a) -> m a
runCC ce = PromptTR.runP (let CC e = ce
MC me = runC e
in me (EmptyS id))
appmk :: Monad m => MetaCont r m a ans -> a -> PromptTR.P r m ans
--appmk x y | trace "in appmk" False = undefined
appmk (EmptyS f) e = return (f e)
appmk (PushP _ sk) e = appmk sk e
appmk (PushSeg (Cont k) sk) e = let MC mc = k e in mc sk
appmk (PushCO f sk) e = appmk sk (f e)
----------------------------------------------------------------------
-- Exported operations
newPrompt :: Monad m => CC r m (Prompt r a)
newPrompt = CC (\ (Cont k) -> MC (\mk -> do p <- PromptTR.newPrompt
let MC me = k p
me mk))
pushPrompt :: Monad m => Prompt r a -> CC r m a -> CC r m a
pushPrompt p (CC e) =
CC (\k -> MC (\mk -> let MC me = runC e
in me (PushP p (PushSeg k mk))))
letSubCont :: Monad m =>
Prompt r b -> (SubCont r m a b -> CC r m b) -> CC r m a
letSubCont p f =
CC (\k -> MC (\mk ->
let (subk,mk') = splitSeq p mk
CC e = f (PushSeg k subk)
MC me = runC e
in me mk'))
pushSubCont :: Monad m => SubCont r m a b -> CC r m a -> CC r m b
pushSubCont subk (CC e) =
CC (\k -> MC (\mk ->
let MC me = runC e
in me (appendSeq subk (PushSeg k mk))))
----------------------------------------------------------------------