diff --git a/Bench_nondet.hs b/Bench_nondet.hs new file mode 100644 --- /dev/null +++ b/Bench_nondet.hs @@ -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 +<> + 0.30 real 0.30 user 0.00 sys + +main_cps5 +<> + 0.60 real 0.58 user 0.01 sys + +main_dir5 (CCExc implementation) +<> + 4.48 real 4.22 user 0.24 sys + +main_dir5io (CCExc implementation) +<> + 5.45 real 5.18 user 0.21 sys + + +main_dir5 (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.70 real 4.44 user 0.23 sys + +main_dir5io (CCCxe implementation) +./Bench_nondet +RTS -tstderr +True +<> + 4.72 real 4.44 user 0.23 sys + +main_ref5io (without pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 68.94 real 67.51 user 1.03 sys + + +main_ref5io (with pushDelimSubCont) +./Bench_nondet +RTS -tstderr +True +<> + 20.50 real 19.92 user 0.46 sys + +-} diff --git a/CC-delcont-alt.cabal b/CC-delcont-alt.cabal new file mode 100644 --- /dev/null +++ b/CC-delcont-alt.cabal @@ -0,0 +1,40 @@ +name: CC-delcont-alt +version: 0.0.0.0 +author: Oleg Kiselyov +maintainer: shelarcy +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. + + . + See the original article at + for more information. + . + This package split multi-prompt delimited control from + 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: diff --git a/CC_Test.hs b/CC_Test.hs new file mode 100644 --- /dev/null +++ b/CC_Test.hs @@ -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] diff --git a/Control/Monad/CC/CCCxe.hs b/Control/Monad/CC/CCCxe.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/CC/CCCxe.hs @@ -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. +-- +-- +-- 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 diff --git a/Control/Monad/CC/CCExc.hs b/Control/Monad/CC/CCExc.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/CC/CCExc.hs @@ -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. +-- +-- +-- 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 +-- 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 diff --git a/Control/Monad/CC/CCRef.hs b/Control/Monad/CC/CCRef.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/CC/CCRef.hs @@ -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. +-- +-- +-- 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 diff --git a/Generator1.hs b/Generator1.hs new file mode 100644 --- /dev/null +++ b/Generator1.hs @@ -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] diff --git a/Generator2.hs b/Generator2.hs new file mode 100644 --- /dev/null +++ b/Generator2.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Mutation.hs b/Mutation.hs new file mode 100644 --- /dev/null +++ b/Mutation.hs @@ -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 diff --git a/ProtocolRecovery.hs b/ProtocolRecovery.hs new file mode 100644 --- /dev/null +++ b/ProtocolRecovery.hs @@ -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 + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain