module Cont where import ST type K r a = (a -> r) -> r unitK :: a -> K r a unitK a = \ c -> c a bindK :: K r a -> (a -> K r b) -> K r b m `bindK` k = \ c -> m (\ a -> k a c) idK = unitST abortK :: r -> K r a abortK v = \ c -> v callccK :: ((a -> K r b) -> K r a) -> K r a callccK h = \ c -> let k a = \ d -> c a in h k c callcc2K :: ((a -> r) -> K r a) -> K r a callcc2K h = \ c -> h c c throwK :: (a -> r) -> a -> K r b throwK c a = \ _ -> c a type KST s v a = K (ST s v) a failK :: String -> KST s () a failK s = abortK (unitST ()) {- setK :: Pos s a -> a -> KST s any () setK p v = \ c s -> c () (snd (p s) v) getK :: Pos s a -> KST s any a getK p = \ c s -> c (fst (p s)) s -} setK :: Pos s a -> a -> KST (s, i, o) any () setK p v = \ c (s, i, o) -> c () (snd (p s) v, i, o) getK :: Pos s a -> KST (s, i, o) any a getK p = \ c (s, i, o) -> c (fst (p s)) (s, i, o) readK :: () -> KST (s, String, o) any Char readK () = \ c (s, ch:i, o) -> c ch (s, i, o) writeK :: Show v => v -> KST (s, i, String) any () writeK v = \ c (s, i, o) -> c () (s, i, o ++ show v) putStrK :: String -> KST (s, i, String) any () putStrK str = \ c (s, i, o) -> c () (s, i, o ++ str) {- foo = \ y -> begin setM xP 1; setM yP y; while getM yP > 0 do begin val x = getM xP in val y = getM yP in if y==10 then break else if y==3 then begin setM yP (y-1); continue end else (); setM xP (x*y); setM yP (y-1) end; getM xP end -} foo :: Integer -> KST ((Integer, Integer), i, o) a Integer foo = \ y -> setK xP 1 `bindK` \ _ -> setK yP y `bindK` \ _ -> (\ _break -> let _while = getK yP `bindK` \ y -> if y > 0 then getK xP `bindK` \ x -> getK yP `bindK` \ y -> (if y == 10 then abortK (_break ()) else if y == 3 then setK yP (y - 1) `bindK` \ _ -> abortK (_while _break) else unitK ()) `bindK` \ _ -> setK xP (x * y) `bindK` \ _ -> setK yP (y - 1) `bindK` \ _ -> _while else unitK () in _while _break) `bindK` \ _ -> getK xP {- bar = \ _ -> begin setM xP 1; label1: if getM xP > 100 then goto label2 else (); setM xP (getM xP * 2); goto label1; label2: getM xP end -} bar :: t -> KST ((Integer, y), i, o) a Integer bar = \ _ -> setK xP 1 `bindK` \ _ -> \ _end -> let label1 = \ _ -> (getK xP `bindK` \ _x -> (if _x > 100 then abortK (label2 ()) else unitK ()) `bindK` \ _ -> getK xP `bindK` \ _x -> setK xP (_x * 2) `bindK` \ _ -> abortK (label1 ())) label2 label2 = \ _ -> getK xP _end in label1 () {- baz = \ x -> callccM (\ k -> 100 + (if x==0 then 1 else k x)) -} baz = \ x -> callccK (\ k -> (if x == 0 then unitK 1 else k x) `bindK` \ _x -> unitK (100 + _x)) {- multlist = \ list -> let aux = \ xs -> \ k -> begin setM xP 1; setM yP xs; while not (null (getM yP)) do begin val y = getM yP in val n = head y in if n == 0 then k 0 else begin setM xP (getM xP*n); setM yP (tail y); putStrM " "; writeM n end end; getM xP end in val result = callccM (\ k -> aux list k) in begin putStrM ";\n result = "; writeM result end -} multlist = \ list -> let aux = \ xs -> unitK (\ k -> setK xP 1 `bindK` \ _ -> setK yP xs `bindK` \ _ -> (\ _break -> let _while = getK yP `bindK` \ _x -> if not (null _x) then getK yP `bindK` \ y -> (if head y == 0 then k 0 else getK xP `bindK` \ _x -> setK xP (_x * head y) `bindK` \ _ -> setK yP (tail y) `bindK` \ _ -> putStrK " " `bindK` \ _ -> writeK (head y)) `bindK` \ _ -> _while else unitK () in _while _break) `bindK` \ _ -> getK xP) in callccK (\ k -> aux list `bindK` \ _f -> _f k) `bindK` \ result -> putStrK "; result=" `bindK` \ _ -> writeK result {- increase = \ n -> \ k -> if n > 10 then () else begin putStrM " i:"; writeM n; increase (n+1) (callcc2M (\ c -> throwM k c)) end; decrease = \ n -> \ k -> if n < 0 then () else begin putStrM " d:"; writeM n; decrease (n-1) (callcc2M (\ c -> throwM k c)) end; coroutine = \ _ -> callcc2M (\ u -> decrease 10 (callcc2M (\ k -> throwM u (increase 0 k)))) -- The Util code above translates into the following code, -- which is untypeable due to the need of an infinite type. increase = \ n -> unitK (\ k -> if n > 10 then unitK () else putStrK " i:" `bindK` \ _ -> writeK n `bindK` \ _ -> increase (n + 1) `bindK` \ _f -> callcc2K (\ c -> throwK k c) `bindK` \ _x -> _f _x) decrease = \ n -> unitK (\ k -> if n < 0 then unitK () else putStrK " d:" `bindK` \ _ -> writeK n `bindK` \ _ -> decrease (n - 1) `bindK` \ _f -> callcc2K (\ c -> throwK k c) `bindK` \ _x -> _f _x) coroutine = \ _ -> callcc2K (\ u -> decrease 10 `bindK` \ f -> callcc2K (\ k -> increase 0 `bindK` \ g -> g k `bindK` \ y -> throwK u y) `bindK` \ x -> f x) -} -- Here is a possible hack. newtype Trick r = Trick { unTrick :: Trick r -> r } -- Trick :: (Trick r -> r) -> Trick r -- unTrick :: Trick r -> (Trick r -> r) increase :: Integer -> K (ST (s, i, String) any) (Trick (ST (s, i, String) any) -> K (ST (s, i, String) any) ()) increase = \ n -> unitK (\ k -> if n > 10 then unitK () else putStrK " i:" `bindK` \ _ -> writeK n `bindK` \ _ -> increase (n + 1) `bindK` \ _f -> callcc2K (\ c -> throwK (unTrick k) (Trick c)) `bindK` \ _x -> _f _x) decrease :: Integer -> K (ST (s, i, String) any) (Trick (ST (s, i, String) any) -> K (ST (s, i, String) any) ()) decrease = \ n -> unitK (\ k -> if n < 0 then unitK () else putStrK " d:" `bindK` \ _ -> writeK n `bindK` \ _ -> decrease (n - 1) `bindK` \ _f -> callcc2K (\ c -> throwK (unTrick k) (Trick c)) `bindK` \ _x -> _f _x) coroutine = \ () -> callcc2K (\ u -> decrease 10 `bindK` \ f -> callcc2K (\ k -> increase 0 `bindK` \ g -> g (Trick k) `bindK` \ y -> throwK u y) `bindK` \ x -> f x) -- e.g. coroutine () unitST ((), "", "")