CC-delcont-alt 0.0.0.0 → 0.1.0.0
raw patch · 5 files changed
+4/−1184 lines, 5 filesdep +CC-delcont-cxedep +CC-delcont-excdep +CC-delcont-ref
Dependencies added: CC-delcont-cxe, CC-delcont-exc, CC-delcont-ref
Files
- CC-delcont-alt.cabal +4/−7
- Control/Monad/CC/CCCxe.hs +0/−250
- Control/Monad/CC/CCExc.hs +0/−258
- Control/Monad/CC/CCRef.hs +0/−629
- Mutation.hs +0/−40
CC-delcont-alt.cabal view
@@ -1,5 +1,5 @@ name: CC-delcont-alt -version: 0.0.0.0 +version: 0.1.0.0 author: Oleg Kiselyov maintainer: shelarcy <shelarcy@gmail.com> license: BSD3 @@ -29,12 +29,9 @@ Generator1.hs, Generator2.hs, ProtocolRecovery.hs library - build-depends: base >= 3 && < 5, mtl - -- CC-delcont-ref, CC-delcont-exc, CC-delcont-cxe + build-depends: base >= 3 && < 5, mtl, + CC-delcont-ref, CC-delcont-exc, CC-delcont-cxe exposed-modules: - Control.Monad.CC.CCCxe - Control.Monad.CC.CCExc - Control.Monad.CC.CCRef - other-modules: Mutation + other-modules: cc-options: ld-options:
− Control/Monad/CC/CCCxe.hs
@@ -1,250 +0,0 @@-{-# LANGUAGE PatternGuards, KindSignatures #-}-{-# LANGUAGE ExistentialQuantification, RankNTypes, ImpredicativeTypes #-}---- | This file is the CPS version of "Control.Monad.CC.CCExc", implementing the identical--- interface------ Monad transformer for multi-prompt delimited control--- It implements the superset of the interface described in------ * \"/A Monadic Framework for Delimited Continuations/\",--- R. Kent Dybvig, Simon Peyton Jones, and Amr Sabry--- JFP, v17, N6, pp. 687--730, 2007.--- <http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR615>------ The first main difference is the use of generalized prompts, which--- do not have to be created with new_prompt and therefore can be defined--- at top level. That removes one of the main practical drawbacks of--- Dybvig et al implementations: the necessity to carry around the prompts--- throughout all the code.------ The delimited continuation monad is parameterized by the flavor--- of generalized prompts. The end of this code defines several flavors;--- the library users may define their own. User-defined flavors are --- especially useful when user's code uses a small closed set of answer-types. --- Flavors PP and PD below are more general, assuming the set of possible--- answer-types is open and Typeable. If the user wishes to create several--- distinct prompts with the same answer-types, the user should use--- the flavor of prompts accepting an integral prompt identifier, such as PD.--- Prompts of the flavor PD correspond to the prompts in Dybvig, Peyton Jones,--- Sabry framework. If the user wishes to generate unique prompts, the user--- should arrange himself for the generation of unique integers--- (using a state monad, for example). On the other hand, the user--- can differentiate answer-types using `newtype.' The latter can--- only produce the set of distinct prompts that is fixed at run-time.--- Sometimes that is sufficient. There is not need to create a gensym--- monad then.------ See "Control.Monad.CC.CCExc" for further comments about the implementation--module Control.Monad.CC.CCCxe (- -- * Types- CC,- SubCont,- CCT,- Prompt,-- -- * Basic delimited control operations- pushPrompt,- takeSubCont,- pushSubCont,- runCC,-- -- * Useful derived operations- abortP,- shiftP,- shift0P,- controlP,-- -- * Pre-defined prompt flavors- PS, ps,- P2, p2L, p2R,- PP, pp,- PM, pm,- PD, newPrompt,- as_prompt_type- ) where--import Control.Monad.Trans-import Data.Typeable -- for prompts of the flavor PP, PD---- | Delimited-continuation monad transformer--- It is parameterized by the prompt flavor p--- The first argument is the regular (success) continuation,--- the second argument is the bubble, or a resumable exception-newtype CC p m a = - CC{unCC:: forall w. (a -> m w) -> - (forall x. SubCont p m x a -> p m x -> m w) -> - m w}---- | The captured sub-continuation-type SubCont p m a b = CC p m a -> CC p m b---- | The type of control operator's body-type CCT p m a w = SubCont p m a w -> CC p m w---- | Generalized prompts for the answer-type w: an injection-projection pair-type Prompt p m w = - (forall x. CCT p m x w -> p m x,- forall x. p m x -> Maybe (CCT p m x w))----- ----------------------------------------------------------------------- | CC monad: general monadic operations--instance Monad m => Monad (CC p m) where- return x = CC $ \ki kd -> ki x-- m >>= f = CC $ \ki kd -> unCC m - (\a -> unCC (f a) ki kd)- (\ctx -> kd (\x -> ctx x >>= f))--instance MonadTrans (CC p) where- lift m = CC $ \ki kd -> m >>= ki--instance MonadIO m => MonadIO (CC p m) where- liftIO = lift . liftIO---- ----------------------------------------------------------------------- Basic Operations of the delimited control interface--pushPrompt :: Monad m =>- Prompt p m w -> CC p m w -> CC p m w-pushPrompt p@(_,proj) body = CC $ \ki kd -> - let kd' ctx body | Just b <- proj body = unCC (b ctx) ki kd- kd' ctx body = kd (\x -> pushPrompt p (ctx x)) body- in unCC body ki kd'----- | Create the initial bubble-takeSubCont :: Monad m =>- Prompt p m w -> CCT p m x w -> CC p m x-takeSubCont p@(inj,_) body = CC $ \ki kd -> kd id (inj body)---- | Apply the captured continuation-pushSubCont :: Monad m => SubCont p m a b -> CC p m a -> CC p m b-pushSubCont = ($)--runCC :: Monad m => CC (p :: (* -> *) -> * -> *) m a -> m a-runCC m = unCC m return err- where- err = error "Escaping bubble: you have forgotten pushPrompt"----- ----------------------------------------------------------------------- Useful derived operations--abortP :: Monad m => - Prompt p m w -> CC p m w -> CC p m any-abortP p e = takeSubCont p (\_ -> e)--shiftP :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-shiftP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushPrompt p (pushSubCont sk (return c))))--shift0P :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-shift0P p f = takeSubCont p $ \sk -> - f (\c -> - pushPrompt p (pushSubCont sk (return c)))--controlP :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-controlP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushSubCont sk (return c)))---- ----------------------------------------------------------------------- Prompt flavors---- | The extreme case: prompts for the single answer-type w.--- The monad (CC PS) then is the monad for regular (single-prompt) --- delimited continuations-newtype PS w m x = PS (CCT (PS w) m x w)---- There is only one generalized prompt of the flavor PS for a--- given answer-type w. It is defined below-ps :: Prompt (PS w) m w-ps = (inj, prj)- where- inj = PS- prj (PS x) = Just x---- | Prompts for the closed set of answer-types--- The following prompt flavor P2, for two answer-types w1 and w2,--- is given as an example. Typically, a programmer would define their--- own variant data type with variants for the answer-types that occur--- in their program.--newtype P2 w1 w2 m x = - P2 (Either (CCT (P2 w1 w2) m x w1) (CCT (P2 w1 w2) m x w2))----- | There are two generalized prompts of the flavor P2"-p2L :: Prompt (P2 w1 w2) m w1-p2L = (inj, prj)- where- inj = P2 . Left- prj (P2 (Left x)) = Just x- prj _ = Nothing--p2R :: Prompt (P2 w1 w2) m w2-p2R = (inj, prj)- where- inj = P2 . Right- prj (P2 (Right x)) = Just x- prj _ = Nothing----- | Prompts for the open set of answer-types--data PP m x = forall w. Typeable w => PP (CCT PP m x w)---- | We need to wrap the type alias CCT into a newtype. Otherwise, gcast--- doesn't work. We can't treat (CCT p m a w) as a an application of--- the `type constructor' (CCT p m a) to the type w: type aliases can't --- be partially applied. But we can treat the type (NCCT p m a w) that way.-newtype NCCT p m a w = NCCT{unNCCT :: CCT p m a w}--pp :: Typeable w => Prompt PP m w-pp = (inj, prj)- where- inj = PP- prj (PP c) = maybe Nothing (Just . unNCCT) (gcast (NCCT c))---- | The same as PP but with the phantom parameter c--- The parameter is useful to statically enforce various constrains--- (statically pass some information between shift and reset)--- The prompt PP is too `dynamic': all errors are detected dynamically--- See Generator2.hs for an example-data PM c m x = forall w. Typeable w => PM (CCT (PM c) m x w)--pm :: Typeable w => Prompt (PM c) m w-pm = (inj, prj)- where- inj = PM- prj (PM c) = maybe Nothing (Just . unNCCT) (gcast (NCCT c))---- | Open set of answer types, with an additional distinction (given by--- integer identifiers)--- This prompt flavor corresponds to the prompts in the Dybvig, Peyton-Jones,--- Sabry framework (modulo the Typeable constraint).--data PD m x = forall w. Typeable w => PD Int (CCT PD m x w)--newPrompt :: Typeable w => Int -> Prompt PD m w-newPrompt mark = (inj, prj)- where- inj = PD mark- prj (PD mark' c) | mark' == mark, - Just (NCCT x) <- gcast (NCCT c) = Just x- prj _ = Nothing---- | It is often helpful, for clarity of error messages, to specify the --- answer-type associated with the prompt explicitly (rather than relying --- on the type inference to figure that out). The following function--- is useful for that purpose.-as_prompt_type :: Prompt p m w -> w -> Prompt p m w-as_prompt_type = const
− Control/Monad/CC/CCExc.hs
@@ -1,258 +0,0 @@-{-# LANGUAGE PatternGuards, KindSignatures #-}-{-# LANGUAGE ExistentialQuantification, Rank2Types, ImpredicativeTypes #-}------ | Monad transformer for multi-prompt delimited control------ It implements the superset of the interface described in------ * \"/A Monadic Framework for Delimited Continuations/\",--- R. Kent Dybvig, Simon Peyton Jones, and Amr Sabry--- JFP, v17, N6, pp. 687--730, 2007.--- <http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR615>------ The first main difference is the use of generalized prompts, which--- do not have to be created with new_prompt and therefore can be defined--- at top level. That removes one of the main practical drawbacks of--- Dybvig et al implementations: the necessity to carry around the prompts--- throughout all the code.------ The delimited continuation monad is parameterized by the flavor--- of generalized prompts. The end of this code defines several flavors;--- the library users may define their own. User-defined flavors are --- especially useful when user's code uses a small closed set of answer-types. --- Flavors PP and PD below are more general, assuming the set of possible--- answer-types is open and Typeable. If the user wishes to create several--- distinct prompts with the same answer-types, the user should use--- the flavor of prompts accepting an integral prompt identifier, such as PD.--- Prompts of the flavor PD correspond to the prompts in Dybvig, Peyton Jones,--- Sabry framework. If the user wishes to generate unique prompts, the user--- should arrange himself for the generation of unique integers--- (using a state monad, for example). On the other hand, the user--- can differentiate answer-types using `newtype.' The latter can--- only produce the set of distinct prompts that is fixed at run-time.--- Sometimes that is sufficient. There is not need to create a gensym--- monad then.------ The second feature of our implementation is the use of the --- bubble-up semantics:--- See page 57 of <http://okmij.org/ftp/gengo/CAG-talk.pdf>--- This present code implements, for the first time, the delimited --- continuation monad CC *without* the use of the continuation monad. --- This code implements CC in direct-style, so to speak.--- Instead of continuations, we rely on exceptions. Our code has a lot--- in common with the Error monad. In fact, our code implements--- an Error monad for resumable exceptions.--module Control.Monad.CC.CCExc (- -- * Types- CC,- SubCont,- CCT,- Prompt,-- -- * Basic delimited control operations- pushPrompt,- takeSubCont,- pushSubCont,- runCC,-- -- * Useful derived operations- abortP,- shiftP,- shift0P,- controlP,-- -- * Pre-defined prompt flavors- PS, ps,- P2, p2L, p2R,- PP, pp,- PM, pm,- PD, newPrompt,- as_prompt_type- ) where--import Control.Monad.Trans-import Data.Typeable -- for prompts of the flavor PP, PD---- | Delimited-continuation monad transformer--- It is parameterized by the prompt flavor p-newtype CC p m a = CC{unCC:: m (CCV p m a)}---- | The captured sub-continuation-type SubCont p m a b = CC p m a -> CC p m b---- | Produced result: a value or a resumable exception-data CCV p m a = Iru a- | forall x. Deru (SubCont p m x a) (p m x) -- The bubble---- | The type of control operator's body-type CCT p m a w = SubCont p m a w -> CC p m w---- | Generalized prompts for the answer-type w: an injection-projection pair-type Prompt p m w = - (forall x. CCT p m x w -> p m x,- forall x. p m x -> Maybe (CCT p m x w))----- ----------------------------------------------------------------------- | CC monad: general monadic operations--instance Monad m => Monad (CC p m) where- return = CC . return . Iru-- m >>= f = CC $ unCC m >>= check- where check (Iru a) = unCC $ f a- check (Deru ctx body) = return $ Deru (\x -> ctx x >>= f) body---instance MonadTrans (CC p) where- lift m = CC (m >>= return . Iru)--instance MonadIO m => MonadIO (CC p m) where- liftIO = lift . liftIO---- ----------------------------------------------------------------------- Basic Operations of the delimited control interface--pushPrompt :: Monad m =>- Prompt p m w -> CC p m w -> CC p m w-pushPrompt p@(_,proj) body = CC $ unCC body >>= check- where- check e@Iru{} = return e- check (Deru ctx body) | Just b <- proj body = unCC $ b ctx- check (Deru ctx body) = return $ Deru (\x -> pushPrompt p (ctx x)) body----- | Create the initial bubble-takeSubCont :: Monad m =>- Prompt p m w -> CCT p m x w -> CC p m x-takeSubCont p@(inj,_) body = CC . return $ Deru id (inj body)---- | Apply the captured continuation-pushSubCont :: Monad m => SubCont p m a b -> CC p m a -> CC p m b-pushSubCont = ($)--runCC :: Monad m => CC (p :: (* -> *) -> * -> *) m a -> m a-runCC m = unCC m >>= check- where- check (Iru x) = return x- check _ = error "Escaping bubble: you have forgotten pushPrompt"----- ----------------------------------------------------------------------- Useful derived operations--abortP :: Monad m => - Prompt p m w -> CC p m w -> CC p m any-abortP p e = takeSubCont p (\_ -> e)--shiftP :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-shiftP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushPrompt p (pushSubCont sk (return c))))--shift0P :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-shift0P p f = takeSubCont p $ \sk -> - f (\c -> - pushPrompt p (pushSubCont sk (return c)))--controlP :: Monad m => - Prompt p m w -> ((a -> CC p m w) -> CC p m w) -> CC p m a-controlP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushSubCont sk (return c)))---- ----------------------------------------------------------------------- Prompt flavors---- | The extreme case: prompts for the single answer-type w.--- The monad (CC PS) then is the monad for regular (single-prompt) --- delimited continuations-newtype PS w m x = PS (CCT (PS w) m x w)---- | There is only one generalized prompt of the flavor PS for a--- given answer-type w. It is defined below-ps :: Prompt (PS w) m w-ps = (inj, prj)- where- inj = PS- prj (PS x) = Just x---- | Prompts for the closed set of answer-types--- The following prompt flavor P2, for two answer-types w1 and w2,--- is given as an example. Typically, a programmer would define their--- own variant data type with variants for the answer-types that occur--- in their program.--newtype P2 w1 w2 m x = - P2 (Either (CCT (P2 w1 w2) m x w1) (CCT (P2 w1 w2) m x w2))----- | There are two generalized prompts of the flavor P2:-p2L :: Prompt (P2 w1 w2) m w1-p2L = (inj, prj)- where- inj = P2 . Left- prj (P2 (Left x)) = Just x- prj _ = Nothing--p2R :: Prompt (P2 w1 w2) m w2-p2R = (inj, prj)- where- inj = P2 . Right- prj (P2 (Right x)) = Just x- prj _ = Nothing----- | Prompts for the open set of answer-types--data PP m x = forall w. Typeable w => PP (CCT PP m x w)---- | We need to wrap the type alias CCT into a newtype. Otherwise, gcast--- doesn't work. We can't treat (CCT p m a w) as a an application of--- the `type constructor' (CCT p m a) to the type w: type aliases can't --- be partially applied. But we can treat the type (NCCT p m a w) that way.-newtype NCCT p m a w = NCCT{unNCCT :: CCT p m a w}--pp :: Typeable w => Prompt PP m w-pp = (inj, prj)- where- inj = PP- prj (PP c) = maybe Nothing (Just . unNCCT) (gcast (NCCT c))---- | The same as PP but with the phantom parameter c--- The parameter is useful to statically enforce various constrains--- (statically pass some information between shift and reset)--- The prompt PP is too `dynamic': all errors are detected dynamically--- See Generator2.hs for an example-data PM c m x = forall w. Typeable w => PM (CCT (PM c) m x w)--pm :: Typeable w => Prompt (PM c) m w-pm = (inj, prj)- where- inj = PM- prj (PM c) = maybe Nothing (Just . unNCCT) (gcast (NCCT c))---- | Open set of answer types, with an additional distinction (given by--- integer identifiers)--- This prompt flavor corresponds to the prompts in the Dybvig, Peyton-Jones,--- Sabry framework (modulo the Typeable constraint).--data PD m x = forall w. Typeable w => PD Int (CCT PD m x w)--newPrompt :: Typeable w => Int -> Prompt PD m w-newPrompt mark = (inj, prj)- where- inj = PD mark- prj (PD mark' c) | mark' == mark, - Just (NCCT x) <- gcast (NCCT c) = Just x- prj _ = Nothing---- | It is often helpful, for clarity of error messages, to specify the --- answer-type associated with the prompt explicitly (rather than relying --- on the type inference to figure that out). The following function--- is useful for that purpose.-as_prompt_type :: Prompt p m w -> w -> Prompt p m w-as_prompt_type = const
− Control/Monad/CC/CCRef.hs
@@ -1,629 +0,0 @@--- | Monad transformer for multi-prompt delimited control------ This library implements the superset of the interface described in------ * \"/A Monadic Framework for Delimited Continuations/\",--- R. Kent Dybvig, Simon Peyton Jones, and Amr Sabry--- JFP, v17, N6, pp. 687--730, 2007.--- <http://www.cs.indiana.edu/cgi-bin/techreports/TRNNN.cgi?trnum=TR615>------ This code is the straightforward implementation of the--- definitional machine described in the above paper. To be precise,--- we implement an equivalent machine, where captured continuations are--- always sandwiched between two prompts. This equivalence as--- well as the trick to make it all well-typed are described in--- the FLOPS 2010 paper. Therefore, to the great extent--- this code is the straightforward translation of delimcc from OCaml.--- The parallel stack of delimcc is the `real' stack now (containing--- parts of the real continuation, that is).------ This code implements, in CPS, what amounts to a segmented stack--- (the technique of implementing call/cc efficiently, first described in--- Hieb, Dybvig and Bruggeman's PLDI 1990 paper).--module Control.Monad.CC.CCRef (- -- * Types- CC,- SubCont,- Prompt,-- -- * Basic delimited control operations- newPrompt,- pushPrompt,- takeSubCont,- pushSubCont,- runCC,-- -- * Optimized primitives- abortP,- pushDelimSubCont,-- -- * Useful derived operations- shiftP,- shift0P,- controlP,- isPromptSet,- - -- * re-export- module Mutation- ) where---import Control.Monad (liftM2)-import Control.Monad.Trans-import Mutation -- Generic references--import Control.Monad.ST -- For tests only---- | Delimited-continuation monad transformer--- The (CC m) monad is the Cont monad with the answer-type (),--- combined with the persistent-state monad. The state PTop is the--- `parallel stack' of delimcc, which is the real stack now. --- The base monad m must support reference cells, that is,--- be a member of the type class Mutation.--- Since we need reference cells anyway, we represent the persistent--- state as a reference cell PTop, which is passed as the environment.--newtype CC m a = CC{unCC:: (a -> m ()) -> PTop m -> m ()}---- We manipulate portions of the stack between two exception frames.--- The type of the exception DelimCCE is ()---- | The type of prompts is just like that in OCaml's delimcc-data Prompt m a = Prompt{mbox :: Ref m (CC m a),- mark :: Mark m}---- | A frame of the parallel stack, associated with each active prompt.--- The frame refers to the prompt indirectly, by pointing to the--- mark field of the prompt. Different prompts have different marks.--- Therefore, although prompts generally have different types, all pframes--- have the same type and can be placed into the same list.--- A pframe also points to an exception frame (in the pfr_ek field).--- That exception frame is created by push_prompt, see below.--data PFrame m = PFrame{pfr_mark :: Mark m,- pfr_ek :: EK m} -- see scAPI below--type PStack m = [PFrame m] -- The parallel stack-type PTop m = Ref m (PStack m) -- The `machine' stack---- | The context between two exception frames: The captured sub-continuation--- It is a fragment of the parallel stack: a list of PFrames in inverse order.--- Since we are in the Cont monad, there is no `real' stack:--- the type Ekfragment is ()--data SubCont m a b = SubCont{subcont_pa :: Prompt m a,- subcont_pb :: Prompt m b,- subcont_ps :: [PFrame m]}----- ----------------------------------------------------------------------- scAPI (see the caml-shift paper)---- | The type of exceptions associated with exception frames--- Only DelimCCE exceptions could ever be raised-type DelimCCE = ()---- | The pointer to an exception frame: a continuation accepting DelimCCE--- (since the monadic action is already a `thunk', we don't need--- to make another one)-type EK m = m ()--{---- How to implement try and obtain the identity EK of the pushed--- exception frame---- The code looks like call/cc, but not quite: we split the --- machine context at the exception frame, evaluating the body in --- essentially the empty environment. To be precise, we evaluate body--- on the stack that contains a single underflow frame, called pop below.--- The operation pop switches the control to the `previous' stack.--ctry :: (Monad m, Mutation m) => (EK m -> CC m ()) -> CC m () -> CC m ()-ctry body handler = CC $ \k ptop -> do- stack <- readRef ptop- let ek = unCC handler k ptop : stack- writeRef ptop ek- let pop () = do- (_:t) <- readRef ptop- writeRef ptop t- k ()- unCC (body ek) pop ptop--}----- in OCaml: reset_ek : ek -> exn -> 'a--- reset_ek :: EK m -> CC m any--- reset_ek ek = CC $ \_ _ -> ek ()---- | Since we are in the Cont monad, there is no `real' stack:-type Ekfragment = ()--- hence, the rest of scAPI is irrelevant:--- copy_stack_fragment and push_stack_fragment do nothing at all---- ----------------------------------------------------------------------- | CC monad: general monadic operations--instance Monad m => Monad (CC m) where- return x = CC $ \k _ -> k x- m >>= f = CC $ \k ptop -> unCC m (\v -> unCC (f v) k ptop) ptop--instance MonadTrans CC where- lift m = CC $ \k _ -> m >>= k--instance MonadIO m => MonadIO (CC m) where- liftIO = lift . liftIO--runCC :: (Monad m, Mutation m) => CC m a -> m a-runCC m = do- ptop <- newRef [] -- make the parallel stack- -- where to store the answer to- ans <- newRef (error "runCC: no prompt was ever set!")- unCC m (writeRef ans) ptop- readRef ans----- ----------------------------------------------------------------------- Utilities---- | Mark is Ref m Bool rather than Ref m () as was in OCaml,--- since we use equi-mutability rather than physical equality when--- comparing marks. Normally, mark is Ref False; we flip it to --- True when we do the equi-mutability test.-type Mark m = Ref m Bool--new_mark :: Mutation m => m (Mark m)-new_mark = newRef False---- | Do the equi-mutability test-with_marked_mark :: (Monad m, Mutation m) => Mark m -> m a -> m a-with_marked_mark mark body = do- writeRef mark True -- set the mark- r <- body- writeRef mark False -- reset it back- return r---- | Check if the given mark is marked-is_marked :: Mutation m => Mark m -> m Bool-is_marked = readRef----- | Contents of the empty mbox --- (see the FLOPS 2010 paper for the explanations)-mbox_empty :: CC m a-mbox_empty = error "Empty mbox"--mbox_receive :: (Monad m, Mutation m) => Prompt m a -> CC m a-mbox_receive p = do- k <- readRef (mbox p)- writeRef (mbox p) mbox_empty- k---- | Operations on the global PStack--push_pframe :: (Monad m, Mutation m) => PTop m -> PFrame m -> m ()-push_pframe ptop fr = do- stack <- readRef ptop- writeRef ptop (fr:stack)--pop_pframe :: (Monad m, Mutation m) => PTop m -> m (PFrame m)-pop_pframe ptop = readRef ptop >>= check- where check [] = error "Empty PStack! Can't be happening"- check (h:t) = writeRef ptop t >> return h- --get_pstack :: (Monad m, Mutation m) => CC m (PStack m)-get_pstack = CC $ \k ptop -> readRef ptop >>= k----- | Split the parallel stack at the given mark, remove the prefix--- (up to but not including the marked frame) and return it in--- the inverse frame order. The frame that used to be at the top of pstack--- is now at the bottom of the returned list.--- The other two returned values are the marked frame and the--- rest of pstack (which contains the marked frame at the top).--unwind :: (Monad m, Mutation m) =>- [PFrame m] -> Mark m -> PStack m ->- m (PFrame m, PStack m, [PFrame m])-unwind acc mark stack = with_marked_mark mark (loop acc stack)- where- loop acc [] = error "No prompt was set" - loop acc s@(h:t) = do- marked <- is_marked (pfr_mark h)- if marked then return (h,s,acc) else loop (h:acc) t---- | The same as above, but the removed frames are discarded-unwind_abort :: (Monad m, Mutation m) =>- Mark m -> PStack m -> m (PFrame m, PStack m)-unwind_abort mark stack = with_marked_mark mark (loop stack)- where- loop [] = error "No prompt was set" - loop s@(h:t) = do- marked <- is_marked (pfr_mark h)- if marked then return (h,s) else loop t---- rev_append l1 l2 == reverse l1 ++ l2-rev_append :: [a] -> [a] -> [a]-rev_append [] l2 = l2-rev_append (h:t) l2 = rev_append t (h:l2)---- ----------------------------------------------------------------------- Basic Operations of the delimited control interface--- All control operators in the end jump to the exception frame--- (in delimcc, that was `raise DelimCCE'; here it is `pfr_ek h')--newPrompt :: (Monad m, Mutation m) => CC m (Prompt m a)-newPrompt = lift $ liftM2 Prompt (newRef mbox_empty) new_mark---- The exception-handling part of try in pushPrompt-popPrompt :: (Monad m, Mutation m) =>- Prompt m w -> CC m w-popPrompt p = CC $ \k ptop -> do- h <- pop_pframe ptop -- remove the exception frame- -- assert (h.pfr_mark == p.mark)- unCC (mbox_receive p) k ptop--pushPrompt :: (Monad m, Mutation m) =>- Prompt m w -> CC m w -> CC m w-pushPrompt p body = CC $ \k ptop -> do- let ek = unCC (popPrompt p) k ptop- let raise = do -- raise the exception- (h:_) <- readRef ptop- pfr_ek h -- h must be an exception frame- push_pframe ptop (PFrame (mark p) ek) -- push the exception frame- unCC body (\res -> writeRef (mbox p) (return res) >> raise) ptop---takeSubCont :: (Monad m, Mutation m) =>- Prompt m b -> (SubCont m a b -> CC m b) -> CC m a-takeSubCont p f = newPrompt >>= \pa -> CC $ \k ptop -> do- let ek = unCC (popPrompt pa) k ptop- stack <- readRef ptop- (h,s,subcontchain) <- unwind [] (mark p) (PFrame (mark pa) ek:stack)- writeRef ptop s- writeRef (mbox p) (f (SubCont pa p subcontchain))- pfr_ek h -- reset_ek is the identity---pushSubCont :: (Monad m, Mutation m) =>- SubCont m a b -> CC m a -> CC m b-pushSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do- let ek = unCC (popPrompt pb) k ptop- ephemeral <- new_mark -- p'' in the caml-shift paper- stack <- readRef ptop- let stack'@(h:_) = rev_append subcontchain (PFrame ephemeral ek:stack)- writeRef ptop stack'- writeRef (mbox pa) m- pfr_ek h -- raise the exception----- | An optimization: pushing the _delimited_ continuation.--- This is the optimization of the pattern------ > pushPrompt (subcont_pb sk) (pushSubcont sk m)------ corresponding to pushing the continuation captured by shift/shift0. --- The latter continuation always has the delimiter at the end.--- Indeed shift can be implemented more efficiently as a primitive--- rather than via push_prompt/control combination...--pushDelimSubCont :: (Monad m, Mutation m) =>- SubCont m a b -> CC m a -> CC m b-pushDelimSubCont (SubCont pa pb subcontchain) m = CC $ \k ptop -> do- let ek = unCC (popPrompt pb) k ptop- stack <- readRef ptop- let stack'@(h:_) = rev_append subcontchain (PFrame (mark pb) ek:stack)- writeRef ptop stack'- writeRef (mbox pa) m- pfr_ek h----- | An efficient variation of take_subcont, which does not capture--- any continuation.--- This code makes it clear that abort is essentially raise.--abortP :: (Monad m, Mutation m) => - Prompt m w -> CC m w -> CC m any-abortP p res = CC $ \k ptop -> do- stack <- readRef ptop- (h,s) <- unwind_abort (mark p) stack- writeRef ptop s- writeRef (mbox p) res- pfr_ek h -- reset_ek is the identity----- | Check to see if a prompt is set-isPromptSet :: (Monad m, Mutation m) => - Prompt m w -> CC m Bool-isPromptSet p = do- stack <- get_pstack- with_marked_mark (mark p) (loop stack)- where- loop [] = return False- loop s@(h:t) = do- marked <- is_marked (pfr_mark h)- if marked then return True else loop t---- pstack_size :: (Monad m, Mutation m) => String -> CC m ()--- pstack_size str = do--- stack <- get_pstack--- trace (unwords ["Pstack:",str,show (length stack)]) (return ())---- ----------------------------------------------------------------------- Useful derived operations--shiftP :: (Monad m, Mutation m) => - Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a-shiftP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushDelimSubCont sk (return c)))--shift0P :: (Monad m, Mutation m) => - Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a-shift0P p f = takeSubCont p $ \sk -> - f (\c -> - pushDelimSubCont sk (return c))--controlP :: (Monad m, Mutation m) => - Prompt m w -> ((a -> CC m w) -> CC m w) -> CC m a-controlP p f = takeSubCont p $ \sk -> - pushPrompt p (f (\c -> - pushSubCont sk (return c)))--------------------------------------------------------------------------- Tests--expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)- else error $ "expected " ++ (show ve) ++- ", computed " ++ (show vp)--assure :: Monad m => CC m Bool -> CC m ()-assure m = do- v <- m- if v then return () else error "assertion failed"---test0 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5--- 5--test1 = (expect 1 =<<) . runCC $ do- p <- newPrompt- assure (isPromptSet p >>= return . not)- pushPrompt p $ (assure (isPromptSet p) >> return 1)--incr :: Monad m => Int -> m Int -> m Int-incr n m = m >>= return . (n +)--test2 = (expect 9 =<<) . runCC $ do- p <- newPrompt- incr 4 . pushPrompt p $ pushPrompt p (return 5)--test3 = (expect 9 =<<) . runCC $ do- p <- newPrompt- incr 4 . pushPrompt p $ (incr 6 $ abortP p (return 5))--test3' = (expect 9 =<<) . runCC $ do- p <- newPrompt- incr 4 . pushPrompt p . pushPrompt p $ (incr 6 $ abortP p (return 5))---- The same, but less efficient-test3'1 = (expect 9 =<<) . runCC $ do- p <- newPrompt- incr 4 . pushPrompt p . pushPrompt p $ - (incr 6 $ takeSubCont p (\_ -> (return 5)))--test3'' = (expect 27 =<<) . runCC $ do- p <- newPrompt- incr 20 . pushPrompt p $ - do- v1 <- pushPrompt p (incr 6 $ abortP p (return 5))- v2 <- abortP p (return 7)- return $ v1 + v2 + 10--test3''1 = (expect 27 =<<) . runCC $ do- p <- newPrompt- incr 20 . pushPrompt p $ - do- v1 <- pushPrompt p (incr 6 $ takeSubCont p (\_ -> return 5))- v2 <- takeSubCont p (\_ -> return 7)- return $ v1 + v2 + 10--test3''' = (print =<<) . runCC $ do- p <- newPrompt- v <- pushPrompt p $ - do- v1 <- pushPrompt p (incr 6 $ abortP p (return 5))- v2 <- abortP p (return 7)- return $ v1 + v2 + 10- assure (isPromptSet p >>= return . not)- v <- abortP p (return 9)- assure (return False)- return $ v + 20--- error--test4 = (expect 35 =<<) . runCC $ do - p <- newPrompt- incr 20 . pushPrompt p $- incr 10 . takeSubCont p $ \sk -> - pushPrompt p (pushSubCont sk (return 5))--test41 = (expect 35 =<<) . runCC $ do- p <- newPrompt- incr 20 . pushPrompt p $ - incr 10 . takeSubCont p $ \sk -> - pushSubCont sk (pushPrompt p (pushSubCont sk (abortP p (return 5))))----- Danvy/Filinski's test---(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))---; --> 117--test5 = (expect 117 =<<) . runCC $ do- p <- newPrompt- incr 10 . pushPrompt p $- incr 2 . shiftP p $ \sk -> incr 100 $ sk =<< (sk 3)--- 117--test5'' = (expect 115 =<<) . runCC $ do- p0 <- newPrompt- p1 <- newPrompt- incr 10 . pushPrompt p0 $- incr 2 . shiftP p0 $ \sk -> - incr 100 $ sk =<< - (pushPrompt p1 (incr 9 $ sk =<< (abortP p1 (return 3))))--test5''' = (expect 115 =<<) . runCC $ do- p0 <- newPrompt- p1 <- newPrompt- incr 10 . pushPrompt p0 $- incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ sk - (pushPrompt p1 (incr 9 $ sk (abortP p1 (return 3))))--test54 = (expect 124 =<<) . runCC $ do- p0 <- newPrompt- p1 <- newPrompt- incr 10 . pushPrompt p0 $- incr 2 . (id =<<) . shiftP p0 $ \sk -> - incr 100 $ sk - (pushPrompt p1 (incr 9 $ sk (abortP p0 (return 3))))--test6 = (expect 15 =<<) . runCC $ do- p1 <- newPrompt- p2 <- newPrompt- let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3))- incr 10 . pushPrompt p1 $ - incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice---- The most difficult test. The difference between the prompts really matters--- now-test7 = (expect 135 =<<) . runCC $ do- p1 <- newPrompt- p2 <- newPrompt- p3 <- newPrompt- let pushtwice sk = pushSubCont sk (pushSubCont sk - (takeSubCont p2- (\sk2 -> pushSubCont sk2- (pushSubCont sk2 (return 3)))))- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)--- 135--test7' = (expect 135 =<<) . runCC $ do- p1 <- newPrompt- p2 <- newPrompt- p3 <- newPrompt- let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)--- 135--test7'' = (expect 135 =<<) . runCC $ do- p1 <- newPrompt- p2 <- newPrompt- p3 <- newPrompt- let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)---- test7 in the ST monad. After all, CC is a monad transformer.--- The only difference is the presence of runST...-test7st = runST (runCC $ do- p1 <- newPrompt- p2 <- newPrompt- p3 <- newPrompt- let pushtwice sk = pushSubCont sk (pushSubCont sk - (takeSubCont p2- (\sk2 -> pushSubCont sk2- (pushSubCont sk2 (return 3)))))- incr 100 . pushPrompt p1 $- incr 1 . pushPrompt p2 $- incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice))--test7st_check = return test7st >>= expect 135------ Checking shift, shift0, control --testls = (expect ["a"] =<<) . runCC $ do- p <- newPrompt- pushPrompt p (- do- let x = shiftP p (\f -> f [] >>= (return . ("a":)))- xv <- x- shiftP p (\_ -> return xv))----- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))-testls0 = (expect [] =<<) . runCC $ do- p <- newPrompt- pushPrompt p (- (return . ("a":)) =<< - (pushPrompt p (shift0P p (\_ -> (shift0P p (\_ -> return []))))))- -testls01 = (expect ["a"] =<<) . runCC $ do- p <- newPrompt- pushPrompt p (- (return . ("a":)) =<< - (pushPrompt p - (shift0P p (\f -> f (shift0P p (\_ -> return []))) >>= id)))- --testlc = (expect [] =<<) . runCC $ do- p <- newPrompt- pushPrompt p (- do- let x = controlP p (\f -> f [] >>= (return . ("a":)))- xv <- x- controlP p (\_ -> return xv))- --testlc' = (expect ["a"] =<<) . runCC $ do- p <- newPrompt- pushPrompt p (- do- let x = controlP p (\f -> f [] >>= (return . ("a":)))- xv <- x- controlP p (\g -> g xv))--- ["a"]--testlc1 = (expect 2 =<<) . runCC $ do- p <- newPrompt- pushPrompt p (do- takeSubCont p (\sk -> - pushPrompt p (pushSubCont sk (return 1)))- takeSubCont p (\sk -> pushSubCont sk (return 2)))----- traversing puzzle by Olivier Danvy--type DelimControl m a b = - Prompt m b -> ((a -> CC m b) -> CC m b) -> CC m a--traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()-traverse op lst = (print =<<) . runCC $ do- p <- newPrompt- let visit [] = return []- visit (h:t) = do- v <- op p (\f -> f t >>= (return . (h:)))- visit v- pushPrompt p (visit lst)----- *CC_Refn> traverse shiftP [1,2,3,4,5]--- [1,2,3,4,5]--- *CC_Refn> traverse controlP [1,2,3,4,5]--- [5,4,3,2,1]--doall = sequence_ [test0, test1, test2, test3, test3', test3'1, - test3'', test3''1, - test4, test41, test5, test5'', test5''', test54,- test6, test7, test7', test7'', test7st_check,- testls, testls0, testls01, testlc, testlc', testlc1- ]--- test3''' should raise an error
− Mutation.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts #-}---- This file is part of the code accompanying the paper--- `Fun with type functions'--- Joint work with Simon Peyton Jones and Chung-chieh Shan--- See the paper for explanations.--module Mutation where-import Data.IORef-import Data.STRef-import Control.Monad.ST-import Control.Monad.Trans---- Start basic-class Mutation m where- type Ref m :: * -> *- newRef :: a -> m (Ref m a)- readRef :: Ref m a -> m a- writeRef :: Ref m a -> a -> m ()--instance Mutation IO where- type Ref IO = IORef- newRef = newIORef- readRef = readIORef- writeRef = writeIORef--instance Mutation (ST s) where- type Ref (ST s) = STRef s- newRef = newSTRef- readRef = readSTRef- writeRef = writeSTRef--- End basic---- Start transformer-instance (Monad m, Mutation m, MonadTrans t)- => Mutation (t m) where- type Ref (t m) = Ref m- newRef = lift . newRef- readRef = lift . readRef- writeRef = (lift .) . writeRef