CC-delcont-alt (empty) → 0.0.0.0
raw patch · 12 files changed
+2160/−0 lines, 12 filesdep +basedep +mtlsetup-changed
Dependencies added: base, mtl
Files
- Bench_nondet.hs +263/−0
- CC-delcont-alt.cabal +40/−0
- CC_Test.hs +239/−0
- Control/Monad/CC/CCCxe.hs +250/−0
- Control/Monad/CC/CCExc.hs +258/−0
- Control/Monad/CC/CCRef.hs +629/−0
- Generator1.hs +90/−0
- Generator2.hs +195/−0
- LICENSE +30/−0
- Mutation.hs +40/−0
- ProtocolRecovery.hs +123/−0
- Setup.lhs +3/−0
+ Bench_nondet.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE FlexibleInstances #-}++-- A benchmark of shift/reset: Filinski's representing non-determinism monads+--+-- The benchmark is taken from Sec 6.1 of+-- Martin Gasbichler, Michael Sperber: Final Shift for Call/cc: Direct+-- Implementation of Shift and Reset, ICFP'02, pp. 271-282. +-- http://www-pu.informatik.uni-tuebingen.de/users/sperber/papers/shift-reset-direct.pdf+-- This code is a straightforward translation of bench_nondet.ml+--+-- This is a micro-benchmark: it is very non-determinism-intensive. It is+-- *not* representative: the benchmark does nothing else but+-- concatenates lists. The List monad does this directly; whereas+-- continuation monads do the concatenation with more overhead (e.g.,+-- building the closures representing continuations). Therefore,+-- the List monad here outperforms all other implementations of +-- non-determinism.+-- It should be stressed that the delimited control is optimized+-- for the case where control operations are infrequent, so we pay+-- as we go. The use of the delimited control operators is more+-- expensive, but the code that does not use delimited control does not+-- have to pay anything for delimited control. +-- Again, in the present micro-benchmark, there is hardly any code that+-- does not use non-determinism, so the overhead of delimited control+-- is very noticeable. That is why this benchmark is good at estimating+-- the overhead of different implementations of delimited control.++-- To compile this code+-- ghc --make -O2 -main-is Bench_nondet.main_list5 Bench_nondet.hs+-- To run this code+-- GHCRTS="-tstderr" /usr/bin/time ./Bench_nondet++module Bench_nondet where++import Control.Monad.CC.CCExc+-- import Control.Monad.CC.CCCxe+-- import Control.Monad.CC.CCRef++import Data.List (sort)+import Control.Monad.Identity+import Control.Monad (MonadPlus(..), liftM2, msum)+-- import System.CPUTime++-- Small language with non-determinism: just like the one in our DSL-WC paper++int :: MonadPlus repr => Int -> repr Int+int x = return x++add :: MonadPlus repr => repr Int -> repr Int -> repr Int+add xs ys = liftM2 (+) xs ys++lam :: MonadPlus repr => (repr a -> repr b) -> repr (a -> repr b)+lam f = return $ f . return++app :: MonadPlus repr => repr (a -> repr b) -> (repr a -> repr b)+app xs ys = do {x <- xs; y <- ys; x y}++amb :: MonadPlus repr => [repr Int] -> repr Int+amb = msum++-- Benchmark cases++test_ww :: MonadPlus repr => repr Int+test_ww = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]++ww_answer = + sort [8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 4, 6, 7, 6, 3, 10, 12, 13,+ 12, 9, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7, 6, 8, 9, 8, 5, 12, 14, 15,+ 14, 11, 11, 13, 14, 13, 10, 9, 11, 12, 11, 8, 7, 9, 10, 9, 6, 13, 15,+ 16, 15, 12, 12, 14, 15, 14, 11, 10, 12, 13, 12, 9, 8, 10, 11, 10, 7,+ 14, 16, 17, 16, 13, 13, 15, 16, 15, 12, 11, 13, 14, 13, 10, 9, 11, 12,+ 11, 8, 15, 17, 18, 17, 14, 40, 42, 43, 42, 39, 38, 40, 41, 40, 37, 36,+ 38, 39, 38, 35, 42, 44, 45, 44, 41]++-- Real benchmark cases++test_www :: MonadPlus repr => repr Int+test_www = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])++test_wwww :: MonadPlus repr => repr Int+test_wwww = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32]))++test_w5 :: MonadPlus repr => repr Int+test_w5 = + let f = lam (\x ->+ add (add x (amb [int 6, int 4, int 2, int 8])) + (amb [int 2, int 4, int 5, int 4, int 1]))+ in f `app` (f `app` + (f `app` (f `app` amb [int 0, int 2, int 3, int 4, int 5, int 32])))+++-- Different implementations of our language (MonadPlus)++-- The List monad: Non-determinism monad as a list of successes++run_list :: [Int] -> [Int]+run_list = id++testl1 = (==) [101, 201, 102, 202] . run_list $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testl2 = ww_answer == sort (run_list test_ww)+++-- CPS-monad, implemented by hand; it must be quite efficient therefore+newtype CPS a = CPS{unCPS:: (a -> [Int]) -> [Int]}++instance Monad CPS where+ return x = CPS $ \k -> k x+ m >>= f = CPS $ \k -> unCPS m (\a -> unCPS (f a) k)++instance MonadPlus CPS where+ mzero = CPS $ \_ -> []+ mplus m1 m2 = CPS $ \k -> unCPS m1 k ++ unCPS m2 k++run_cps :: CPS Int -> [Int]+run_cps m = unCPS m (\x -> [x])+++testc1 = (==) [101, 201, 102, 202] . run_cps $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testc2 = ww_answer == sort (run_cps test_ww)++-- CCEx monad++-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance Monad m => MonadPlus (CC (PS [Int]) m) where+ mzero = abortP ps (return [])+ mplus m1 m2 = takeSubCont ps (\k ->+ liftM2 (++)+ (pushPrompt ps (pushSubCont k m1))+ (pushPrompt ps (pushSubCont k m2)))++run_dir :: CC (PS [Int]) Identity Int -> [Int]+run_dir m = runIdentity . runCC $+ pushPrompt ps (m >>= return . (:[]))+++testd1 = (==) [101, 201, 102, 202] . run_dir $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testd2 = ww_answer == sort (run_dir test_ww)++{-+-- CCRef monad++-- Need a reader-monad layer to propagate the prompt+newtype CCR m a = CCR{unCCR :: Prompt m [Int] -> CC m a}++instance Monad m => Monad (CCR m) where+ return x = CCR $ \_ -> return x+ m >>= f = CCR $ \p -> unCCR m p >>= \v -> unCCR (f v) p+++-- Not a very optimal implementation of mplus (a tree would be better)+-- But is suffices as a benchmark of different implementations of CC+instance (Monad m, Mutation m) => MonadPlus (CCR m) where+ mzero = CCR $ \p -> abortP p (return [])+ mplus m1 m2 = CCR $ \p ->+ takeSubCont p (\k ->+ liftM2 (++)+ (pushDelimSubCont k (unCCR m1 p))+ (pushDelimSubCont k (unCCR m2 p)))++run_ref :: CCR IO Int -> IO [Int]+run_ref m = runCC $ do+ p <- newPrompt+ pushPrompt p (unCCR m p >>= return . (:[]))++testr1 = ((return . ((==) [101, 201, 102, 202])) =<<) . run_ref $+ add (amb [int 1, int 2]) (amb [int 100, int 200])++testr2 = do+ r <- run_ref test_ww+ return $ ww_answer == sort r++main_ref5io = do+ l <- run_ref test_w5+ print $ length l == 960000+-}+++-- Benchmarks themselves++main_list3 = print $ 2400 == (length . run_list $ test_www)+main_list4 = print $ 48000 == (length . run_list $ test_wwww)+main_list5 = print $ 960000 == (length . run_list $ test_w5)++main_cps3 = print $ 2400 == (length . run_cps $ test_www)+main_cps4 = print $ 48000 == (length . run_cps $ test_wwww)+main_cps5 = print $ 960000 == (length . run_cps $ test_w5)++-- We expect the direct implementation to be slower since CC is the transformer,+-- whereas CPS is not. The latter is hand-written for a specific answer-type.+main_dir3 = print $ 2400 == (length . run_dir $ test_www)+main_dir4 = print $ 48000 == (length . run_dir $ test_wwww)+main_dir5 = print $ 960000 == (length . run_dir $ test_w5)++-- Instantiate CC to the IO as the base monad, attempting to quantify the+-- effect of the Identity transformer+main_dir5io = do+ l <- runCC $ pushPrompt ps (test_w5 >>= return . (:[]))+ print $ length l == 960000++{- Median of 5 runs++main_list5+<<ghc: 186526764 bytes, 356 GCs, 619182/1156760 avg/max bytes residency (3 samples), 4M in use, 0.00 INIT (0.00 elapsed), 0.25 MUT (0.25 elapsed), 0.06 GC (0.06 elapsed) :ghc>>+ 0.30 real 0.30 user 0.00 sys++main_cps5+<<ghc: 231580040 bytes, 442 GCs, 4017/4104 avg/max bytes residency (24 samples), 2M in use, 0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed), 0.31 GC (0.33 elapsed) :ghc>>+ 0.60 real 0.58 user 0.01 sys++main_dir5 (CCExc implementation)+<<ghc: 780415108 bytes, 1489 GCs, 10459973/39033060 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.30 MUT (1.32 elapsed), 2.92 GC (3.14 elapsed) :ghc>>+ 4.48 real 4.22 user 0.24 sys++main_dir5io (CCExc implementation)+<<ghc: 1148031880 bytes, 2190 GCs, 10339954/38941944 avg/max bytes residency (14 samples), 108M in use, 0.00 INIT (0.00 elapsed), 2.15 MUT (2.20 elapsed), 3.04 GC (3.24 elapsed) :ghc>>+ 5.45 real 5.18 user 0.21 sys+++main_dir5 (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065016 bytes, 1891 GCs, 10473968/38790660 avg/max bytes residency (14 samples), 110M in use, 0.00 INIT (0.00 elapsed), 1.45 MUT (1.49 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+ 4.70 real 4.44 user 0.23 sys++main_dir5io (CCCxe implementation)+./Bench_nondet +RTS -tstderr +True+<<ghc: 991065412 bytes, 1891 GCs, 10364029/37920012 avg/max bytes residency (14 samples), 109M in use, 0.00 INIT (0.00 elapsed), 1.46 MUT (1.50 elapsed), 2.99 GC (3.20 elapsed) :ghc>>+ 4.72 real 4.44 user 0.23 sys++main_ref5io (without pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 19050261764 bytes, 36337 GCs, 10620542/49328200 avg/max bytes residency (16 samples), 123M in use, 0.00 INIT (0.00 elapsed), 61.45 MUT (62.70 elapsed), 6.06 GC (6.21 elapsed) :ghc>>+ 68.94 real 67.51 user 1.03 sys+++main_ref5io (with pushDelimSubCont)+./Bench_nondet +RTS -tstderr +True+<<ghc: 5666546308 bytes, 10809 GCs, 10538302/46414760 avg/max bytes residency (14 samples), 114M in use, 0.00 INIT (0.00 elapsed), 16.27 MUT (16.68 elapsed), 3.65 GC (3.80 elapsed) :ghc>>+ 20.50 real 19.92 user 0.46 sys++-}
+ CC-delcont-alt.cabal view
@@ -0,0 +1,40 @@+name: CC-delcont-alt +version: 0.0.0.0 +author: Oleg Kiselyov +maintainer: shelarcy <shelarcy@gmail.com> +license: BSD3 +license-file: LICENSE +category: Control +Synopsis: Three new monad transformers for multi-prompt delimited control +Description: Oleg Kiselyov's three new monad transformers for multi-prompt delimited control + (released with his permission) + . + 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> + . + See the original article at <http://okmij.org/ftp/continuations/implementations.html#CC-monads> + for more information. + . + This package split multi-prompt delimited control from + <http://hackage.haskell.org/package/liboleg> for usability. +stability: experimental +cabal-version: >= 1.8 +build-type: Simple +extra-source-files: + Bench_nondet.hs + CC_Test.hs + Generator1.hs, Generator2.hs, ProtocolRecovery.hs + +library + 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 + cc-options: + ld-options:
+ CC_Test.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- Tests of the CC Transformer operations: CCExe++module CC_testsT where++import Control.Monad.CC.CCCxe+-- import Control.Monad.CC.CCExc+import Control.Monad.Trans+import Data.Typeable++expect ve vp = if ve == vp then putStrLn $ "expected answer " ++ (show ve)+ else error $ "expected " ++ (show ve) +++ ", computed " ++ (show vp)++test1 = runCC (return 1 >>= (return . (+ 4))) >>= expect 5+-- 5++doall = sequence_ [test1, test2, test3, test3', test3'', + test4, test5, test41, test5''1, test5''21, test5''22,+ test5''3, test54,+ test6, test7, test7', test7'',+ testls, testls0, testls01, testlc, testlc', testlc1+ ]+-- test3''' should raise an error++incr :: Monad m => Int -> m Int -> m Int+incr n m = m >>= return . (n +)++test2 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ pushPrompt ps (return 5)+-- 9++test3 = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3' = (expect 9 =<<) . runCC $+ incr 4 . pushPrompt ps . pushPrompt ps $ (incr 6 $ abortP ps (return 5))++test3'' = (expect 27 =<<) . runCC $+ incr 20 . pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10++test3''' = (print =<<) . runCC $ do+ v <- pushPrompt ps $ + do+ v1 <- pushPrompt ps (incr 6 $ abortP ps (return 5))+ v2 <- abortP ps (return 7)+ return $ v1 + v2 + 10+ v <- abortP ps (return 9)+ return $ v + 20+-- error++test4 = (expect 35 =<<) . runCC $+ incr 20 . pushPrompt ps $+ incr 10 . takeSubCont ps $ \sk -> + pushPrompt ps (pushSubCont sk (return 5))++test41 = (expect 35 =<<) . runCC $ + incr 20 . pushPrompt ps $ + incr 10 . takeSubCont ps $ \sk -> + pushSubCont sk (pushPrompt ps (pushSubCont sk (abortP ps (return 5))))+++-- Danvy/Filinski's test+--(display (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))))+--; --> 117++test5 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt ps $+ incr 2 . shiftP ps $ \sk -> incr 100 $ sk =<< (sk 3)+-- 117++-- multi-prompt tests++-- Testing prompt flavor P2++test5''1 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p2L $ + incr 2 . (id =<<) . shiftP p2L $ \sk -> + incr 100 $ (sk (pushPrompt p2R+ (sk (sk (abortP p2R (return 3))))))++-- Testing prompt flavor PP++-- Here, p1 and p0 have the same type, and so p0 is actually the same as p1+test5''21 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp++-- Now, p1 and p0 have different types+newtype NInt = NInt{unNInt :: Int} deriving Typeable+test5''22 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (lunNInt (pushPrompt p1+ (lNInt + (sk (sk (abortP p1 (return (NInt 3)))))))))+ where p0 = pp `as_prompt_type` (0::Int)+ p1 = pp+ lunNInt m = m >>= return . unNInt+ lNInt m = m >>= return . NInt++-- Testing prompt flavor PD+-- p0 and p1 have the same type, but are different+test5''3 = (expect 115 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p1 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test54 = (expect 117 =<<) . runCC $+ incr 10 . pushPrompt p0 $ + incr 2 . (id =<<) . shiftP p0 $ \sk -> + incr 100 $ (sk (pushPrompt p1+ (sk (sk (abortP p0 (return 3))))))+ where p0 = newPrompt 0 `as_prompt_type` (0::Int)+ p1 = newPrompt 1++test6 = (expect 15 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk (return 3)) in+ incr 10 . pushPrompt p1 $ + incr 1 . pushPrompt p2 $ takeSubCont p1 pushtwice+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+++-- The most difficult test. The difference between the prompts really matters+-- now+test7 = (expect 135 =<<) . runCC $+ let pushtwice sk = pushSubCont sk (pushSubCont sk + (takeSubCont p2+ (\sk2 -> pushSubCont sk2+ (pushSubCont sk2 (return 3)))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (takeSubCont p1 pushtwice)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shiftP p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shiftP p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+-- 135++test7'' = (expect 135 =<<) . runCC $+ let pushtwice f = f (f (shift0P p2 (\f2 -> f2 =<< (f2 3))))+ in+ incr 100 . pushPrompt p1 $+ incr 1 . pushPrompt p2 $+ incr 10 . pushPrompt p3 $ (shift0P p1 pushtwice >>= id)+ where p1 = newPrompt 1 `as_prompt_type` (0::Int)+ p2 = newPrompt 2+ p3 = newPrompt 3+++-- Checking shift, shift0, control ++testls = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = shiftP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ shiftP ps (\_ -> return xv))+++-- (display (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))))+testls0 = (expect [] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps (shift0P ps (\_ -> (shift0P ps (\_ -> return []))))))+ +testls01 = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ (return . ("a":)) =<< + (pushPrompt ps + (shift0P ps (\f -> f (shift0P ps (\_ -> return []))) >>= id)))+ ++testlc = (expect [] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\_ -> return xv))+ ++testlc' = (expect ["a"] =<<) . runCC $+ pushPrompt ps (+ do+ let x = controlP ps (\f -> f [] >>= (return . ("a":)))+ xv <- x+ controlP ps (\g -> g xv))+-- ["a"]++testlc1 = (expect 2 =<<) . runCC $+ pushPrompt ps (do+ takeSubCont ps (\sk -> + pushPrompt ps (pushSubCont sk (return 1)))+ takeSubCont ps (\sk -> pushSubCont sk (return 2)))+++-- traversing puzzle by Olivier Danvy++type DelimControl m a b = + Prompt (PS b) m b -> + ((a -> CC (PS b) m b) -> CC (PS b) m b) -> CC (PS b) m a++traverse :: Show a => DelimControl IO [a] [a] -> [a] -> IO ()+traverse op lst = (print =<<) . runCC $+ let visit [] = return []+ visit (h:t) = do+ v <- op ps (\f -> f t >>= (return . (h:)))+ visit v+ in pushPrompt ps (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]
+ Control/Monad/CC/CCCxe.hs view
@@ -0,0 +1,250 @@+{-# 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 view
@@ -0,0 +1,258 @@+{-# 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 view
@@ -0,0 +1,629 @@+-- | 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
+ Generator1.hs view
@@ -0,0 +1,90 @@+-- Generators in Haskell+--+-- We translate the in-order tree traversal example from an old article+-- Generators in Icon, Python, and Scheme, 2004.+-- http://okmij.org/ftp/Scheme/enumerators-callcc.html#Generators+--+-- using Haskell and delimited continuations rather than call/cc + mutation.+-- The code is shorter, and it even types.+-- To be honest, we actually translate the OCaml code generator.ml++-- In this code, we use a single global prompt (that is, ordinary shift0)+-- Generator2.hs shows the need for several prompts.++module Generator1 where++import Control.Monad.CC.CCExc+import Control.Monad.Trans (liftIO, lift)++import Control.Monad.ST -- for pure tests+import Data.STRef++{-+A sample program Python programmers seem to be proud of: an in-order+traversal of a tree:++ >>>> # A recursive generator that generates Tree leaves in in-order.+ >>> def inorder(t):+ ... if t:+ ... for x in inorder(t.left):+ ... yield x+ ... yield t.label+ ... for x in inorder(t.right):+ ... yield x++Given below is the complete implementation in Haskell.+-}+++-- A few preliminaries: define the tree and build a sample tree++type Label = Int+data Tree = Leaf | Node Label Tree Tree deriving Show++make_full_tree :: Int -> Tree+make_full_tree depth = loop 1 depth+ where + loop label 0 = Leaf+ loop label n = Node label (loop (2*label) (pred n)) (loop (2*label+1) (pred n))++tree1 = make_full_tree 3++-- In Python, `yield' is a keyword. In Haskell, it is a regular function.+-- Furthermore, it is a user-defined function, in one line of code.+-- To get generators there is no need to extend a language.++type P m a = PS (Res m a) -- the type of the single prompt (recursive)+newtype Res m a = Res ( (a -> CC (P m a) m ()) -> CC (P m a) m () )+outRes body (Res f) = f body++yield :: Monad m => a -> CC (P m a) m ()+yield v = shift0P ps (\k -> return . Res $ \b -> b v >> k () >>= outRes b)++-- The enumerator: the for-loop essentially+enumerate iterator body = + pushPrompt ps (iterator >> (return . Res . const $ return ())) >>=+ outRes body++-- The in_order function itself: compare with the Python version+in_order :: (Monad m) => Tree -> CC (P m Label) m ()+in_order Leaf = return ()+in_order (Node label left right) = do+ in_order left+ yield label+ in_order right++-- Print out the result of the in-order traversal+test_io :: IO ()+test_io = runCC $ enumerate (in_order tree1) (liftIO . print)++-- 4 2 5 1 6 3 7++-- Or return it as a pure list; the effects are encapsulated+test_st :: [Label]+test_st = runST (do+ res <- newSTRef []+ let body v = modifySTRef res (v:)+ runCC $ enumerate (in_order tree1) (lift . body)+ readSTRef res >>= return . reverse)++-- [4,2,5,1,6,3,7]
+ Generator2.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++-- Generators in Haskell+--+-- We translate the in-order tree traversal example from an old article+-- Generators in Icon, Python, and Scheme, 2004.+-- http://okmij.org/ftp/Scheme/enumerators-callcc.html#Generators+--+-- using Haskell and delimited continuations rather than call/cc + mutation.+-- The code is shorter, and it even types.+-- To be honest, we actually translate the OCaml code generator.ml++-- This code is the extension of Generator1.hs; we use delimited+-- control not only to implement the generator. We also use delimited+-- control to accumulate the results in a list. We need two different+-- prompts then (with two different answer-types, as it happens).+-- This file illustrates the prompt flavors PP and PM, using newtypes+-- to define private global prompts (global prompts that are private to+-- the current module).+++module Generator2 where++import Control.Monad.CC.CCExc+import Control.Monad.Trans (liftIO, lift)+import Data.Typeable++{-+A sample program Python programmers seem to be proud of: an in-order+traversal of a tree:++ >>>> # A recursive generator that generates Tree leaves in in-order.+ >>> def inorder(t):+ ... if t:+ ... for x in inorder(t.left):+ ... yield x+ ... yield t.label+ ... for x in inorder(t.right):+ ... yield x++Given below is the complete implementation in Haskell.+-}+++-- A few preliminaries: define the tree and build a sample tree++type Label = Int+data Tree = Leaf | Node Label Tree Tree deriving Show++make_full_tree :: Int -> Tree+make_full_tree depth = loop 1 depth+ where + loop label 0 = Leaf+ loop label n = Node label (loop (2*label) (pred n)) (loop (2*label+1) (pred n))++tree1 = make_full_tree 3++-- In Python, `yield' is a keyword. In Haskell, it is a regular function.+-- Furthermore, it is a user-defined function, in one line of code.+-- To get generators there is no need to extend a language.++-- ------------------------------------------------------------------------+-- First, we try the prompt flavor PP++-- The answer-type for one of the prompts+newtype ResP m a = ResP ( (a -> CC PP m ()) -> CC PP m () )++instance Typeable1 m => Typeable1 (ResP m) where+ typeOf1 x = mkTyConApp (mkTyCon "ResP") [m]+ where m = typeOf1 (undefined:: m ())++outResP body (ResP f) = f body++-- One prompt, used by the generator (the yield/enumerate pair)+-- We instantiate the global pp to the desired answer-type.+ppy :: (Typeable1 m, Typeable a) => Prompt PP m (ResP m a)+ppy = pp++-- The rest of the code, up to test_io, is the same as that in Generator1.hs+yieldP :: (Typeable1 m, Typeable a) => Monad m => a -> CC PP m ()+yieldP v = shift0P ppy (\k -> return . ResP $ \b -> b v >> k () >>= outResP b)++-- The enumerator: the for-loop essentially+enumerateP :: (Typeable1 m, Typeable a, Monad m) =>+ CC PP m () -> (a -> CC PP m ()) -> CC PP m ()+enumerateP iterator body = + pushPrompt ppy (iterator >> (return . ResP . const $ return ())) >>=+ outResP body++-- The in_order function itself: compare with the Python version+in_orderP :: (Typeable1 m, Monad m) => Tree -> CC PP m ()+in_orderP Leaf = return ()+in_orderP (Node label left right) = do+ in_orderP left+ yieldP label+ in_orderP right++-- Print out the result of the in-order traversal+test_ioP :: IO ()+test_ioP = runCC $ + enumerateP (in_orderP tree1) (liftIO .(print :: (Int -> IO ())))++-- 4 2 5 1 6 3 7++-- ------------------------------------------------------------------------+-- Using the prompt flavor PM++-- The above code works. We can define the second pair of operators+-- to accummulate the result into a list. Yet, the solution is+-- not very satisfactory. We notice that the prompt type ppy is+-- polymorphic over a, the elements we yield. What ensures that+-- `yieldP' yields elements of the same type that enumerateP can pass to the+-- body of the loop? Nothing, actually, at compile time. If yieldP and+-- enumerateP do not agree on the type of the elements, a run-time+-- error will occur.+-- This is where the PM prompt type comes in handy. It has a phantom+-- type parameter c, which can be used to communicate between+-- producers and consumers of the effect. We use the type parameter c+-- to communicate the type of elements, between yield and enumerate.+-- Since the parameter is phantom, it costs us nothing at run-time.++-- The answer-type for one of the prompts+newtype Res m a = Res ( (a -> CC (PM a) m ()) -> CC (PM a) m () )++instance Typeable1 m => Typeable1 (Res m) where+ typeOf1 x = mkTyConApp (mkTyCon "Res") [m]+ where m = typeOf1 (undefined:: m ())++outRes body (Res f) = f body++-- One prompt, used by the generator (the yield/enumerate pair)+py :: (Typeable1 m, Typeable a) => Prompt (PM a) m (Res m a)+py = pm++-- The rest of the code, up to test_io, is the same as that in Generator1.hs+yield :: (Typeable1 m, Typeable a) => Monad m => a -> CC (PM a) m ()+yield v = shift0P py (\k -> return . Res $ \b -> b v >> k () >>= outRes b)++-- The enumerator: the for-loop essentially+enumerate :: (Typeable1 m, Typeable a, Monad m) =>+ CC (PM a) m () -> (a -> CC (PM a) m ()) -> CC (PM a) m ()+enumerate iterator body = + pushPrompt py (iterator >> (return . Res . const $ return ())) >>=+ outRes body++-- The in_order function itself: compare with the Python version+in_order :: (Typeable1 m, Monad m) => Tree -> CC (PM Label) m ()+in_order Leaf = return ()+in_order (Node label left right) = do+ in_order left+ yield label+ in_order right++-- Print out the result of the in-order traversal+test_io :: IO ()+test_io = runCC $ enumerate (in_order tree1) (liftIO .(print :: (Int -> IO ())))++-- 4 2 5 1 6 3 7+++-- The second application of control: accumulating the results in a list++-- The answer-type for the second prompt. We use newtype for identification+newtype Acc a = Acc [a] deriving Typeable+toAcc v (Acc l) = return . Acc $ v:l++-- The second prompt, used by the acc/accumulated pair+-- Again we use the mark of PM to communicate the type of the elements+-- between `acc' and `accumulated'. It happens to be the same type used+-- by yield/enumetrate.+-- If that was not the case, we could have easily arranged for a type-level+-- record (see HList or the TFP paper).+pa :: (Typeable a) => Prompt (PM a) m (Acc a)+pa = pm++acc :: (Typeable a, Monad m) => a -> CC (PM a) m ()+acc v = shift0P pa (\k -> k () >>= toAcc v)++accumulated :: (Typeable a, Monad m) => CC (PM a) m () -> CC (PM a) m [a]+accumulated body = + pushPrompt pa (body >> return (Acc [])) >>= \ (Acc l) -> return l++test_acc :: [Label]+test_acc = runIdentity . runCC . accumulated $+ (enumerate (in_order tree1) acc)++-- [4,2,5,1,6,3,7]+++-- To avoid importing mtl, we define Identity on our own+newtype Identity a = Identity{runIdentity :: a} deriving (Typeable)++instance Monad Identity where+ return = Identity+ m >>= f = f $ runIdentity m
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010 Oleg Kiselyov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Mutation.hs view
@@ -0,0 +1,40 @@+{-# 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
+ ProtocolRecovery.hs view
@@ -0,0 +1,123 @@+-- Example of CCCxe++-- Communicating with a server according to a fixed protocol;+-- reporting wrong responses to the supervisor;+-- permitting the recovery from protocol errors if the supervisor+-- decides that the error can be recovered by re-reading.+--+-- The problem was posed by magicloud.magiclouds in the message+-- http://www.haskell.org/pipermail/haskell-cafe/2011-January/088600.html+++-- This code is interactive, letting the user act as a good or a bad+-- server+--+-- Sample interactions (after invoking 'main')+-- 1,2 normal sequence+-- 1,3,3,3,2 the same with debugging+-- 3,1,3,2 the same with debugging+-- 4 disconnect+-- 1,4 disconnect+-- 1,1 bad, bad server++module ProtocolRecovery where++-- Import (one of the) CC libraries+-- http://okmij.org/ftp/continuations/implementations.html#CC-monads++import Control.Monad.CC.CCCxe+import Control.Monad.Trans++-- Requests and responses+data Req = Req_hello | Req_who_are_you deriving Show+data Res = Res_hello | Res_name String | Res_debug | Res_disconnect+ deriving (Eq, Show)+++-- The error codes+data Err = Err_bad_resp Res -- more alternatives could be added+ deriving Show++-- The answer of a CC computation+-- The answer is either normal or an out-of-band message to the+-- supervisor, with an error code and the resumption.+-- We shall use the prompt flavor PS for the single answer-type CCAns++data CCAns = Done -- OK, finished+ | Exc Err -- exception with the code+ (OurM CCAns) -- resumption+ -- cleanup procedure may be added++type OurM a = CC (PS CCAns) IO a -- our monad++-- The main exchange with the server+exchange :: OurM ()+exchange = do+ send Req_hello+ readMsg >>= expect (== Res_hello)+ send Req_who_are_you+ readMsg >>= expect (\x -> case x of Res_name _ -> True; _ -> False)+ return ()+++-- Check the response to see it matches our expectations+-- We report an unexpected response to the parent; +-- if the parent tells us to continue, we re-read from the server+expect :: (Res -> Bool) -> Res -> OurM ()++expect pred msg | pred msg = return ()++expect pred msg = do+ shiftP ps (\k -> return $ Exc (Err_bad_resp msg) (k ()))+ readMsg >>= expect pred -- re-read, re-process++++main = do+ connect+ runCC $ loop $ pushPrompt ps ( exchange >> return Done )+ disconnect+ where+ loop m = m >>= check++ check :: CCAns -> OurM ()+ check Done = return ()+ check (Exc err resum) = do+ out ["Exception:", show err]+ decide err resum++ -- decide what to do on error+ decide (Err_bad_resp Res_disconnect) _ = do+ out ["Aborting"]+ return ()+ decide (Err_bad_resp Res_debug) resum = do+ out ["DEBUG"]+ loop resum -- resuming+ decide _ _ = do+ out ["Really bad response!"]+ return () -- quitting+++-- stubs++connect = out ["Client Connected"]+disconnect = out ["Client Dis-connected"]++send :: MonadIO m => Req -> m ()+send req = out ["sending:",show req]++readMsg :: MonadIO m => m Res+readMsg = do+ out ["Enter response, as a number 1..4"]+ resp_code <- liftIO getLine >>= return . read+ case resp_code of+ 1 -> return $ Res_hello+ 2 -> return $ Res_name "dummy"+ 3 -> return $ Res_debug+ 4 -> return $ Res_disconnect+ _ -> out ["Bad code. Try again"] >> readMsg+++out :: MonadIO m => [String] -> m ()+out = liftIO . putStrLn . unwords+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain