haskell practice

cps.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Prelude (Eq, Num, Int, show, undefined, (==), (<), (>), (.))
import qualified Prelude


id :: ((a -> r) -> r) -> ((a -> r) -> r)
id cx = \k -> cx k

id' :: a -> (a -> r) -> r
id' x = \k -> k x

const :: ((a -> r) -> r) -> ((b -> r) -> r) -> ((a -> r) -> r)
const cx _ = \k -> cx k

const' :: a -> b -> (a -> r) -> r
const' x _ = \k -> k x

plus :: Num t => t -> t -> (t -> r) -> r
plus x y = \k -> k (x Prelude.+ y)

(+) :: Num t => ((t -> r) -> r) -> ((t -> r) -> r) -> ((t -> r) -> r)
ca + cb = \k -> ca (\a -> cb (\b -> k (a Prelude.+ b)))

pure :: a -> ((a -> r) -> r)
pure x = \k -> k x

lift :: (a -> b) -> ((a -> b) -> r) -> r
lift = pure

(<*>) :: (((a -> b) -> r) -> r) -> ((a -> r) -> r) -> ((b -> r) -> r)
cf <*> cx = \k -> cf (\f -> cx (\x -> k (f x)))

(<$>) :: (a -> b) -> ((a -> r) -> r) -> ((b -> r) -> r)
f <$> cx = \k -> cx (\x -> k (f x))

(>>=) :: ((a -> r) -> r) -> (a -> (b -> r) -> r) -> (b -> r) -> r
m >>= f = \k -> m (\a -> f a (\b -> k b))

join :: ((((a -> r) -> r) -> r) -> r) -> ((a -> r) -> r)
join mm = mm >>= \m -> m

(>=>) :: (a -> ((b -> r) -> r)) -> (b -> ((c -> r) -> r)) -> (a -> ((c -> r) -> r))
f >=> g = \x -> f x >>= g

(<=<) :: (b -> ((c -> r) -> r)) -> (a -> ((b -> r) -> r)) -> (a -> ((c -> r) -> r))
(<=<) = Prelude.flip (>=>)

fmap :: (a -> b) -> ((a -> r) -> r) -> ((b -> r) -> r)
fmap = (<$>)

($) :: (((a -> b) -> r) -> r) -> ((a -> r) -> r) -> ((b -> r) -> r)
cf $ cx = \k -> cf (\f -> cx (\x -> k (f x)))

cons :: ((a -> r) -> r) -> (([a] -> r) -> r) -> (([a] -> r) -> r)
cons cx cxs = (:) <$> cx <*> cxs

m _ []     = []
m f (x:xs) = (:) (f x) (m f xs)

sequence :: [(a -> r) -> r] -> (([a] -> r) -> r)
sequence [] = \k -> k []
sequence (cx:cxs) = \k -> cx (\x -> sequence cxs (\xs -> k (x:xs)))

map :: forall a b r. (((a -> b) -> r) -> r) -> [(a -> r) -> r] -> (([b] -> r) -> r)
map _ [] = \k -> k []
map cf (cx:cxs) = cons (cf <*> cx) (map cf cxs)

-- map2 :: m (a -> b) -> [m a] -> m [b]
map2 :: (((a -> b) -> r) -> r) -> [(a -> r) -> r] -> (([b] -> r) -> r)
map2 = map

-- map2' :: m (a -> b) -> m [a] -> m [b]
map2' :: (((a -> b) -> r) -> r) -> (([a] -> r) -> r) -> (([b] -> r) -> r)
map2' cf cxs =
  cf >>= \f ->
  cxs >>= \xs ->
  pure (Prelude.fmap f xs)

-- map3 :: (a -> m b) -> [m a] -> m [b]
map3 :: (a -> (b -> r) -> r) -> [(a -> r) -> r] -> (([b] -> r) -> r)
map3 _ [] = \k -> k []
map3 f (cx:cxs) =
  cx >>=
  f >>= \y ->
  map3 f cxs >>= \ys ->
  pure (y:ys)

-- map3' :: (a -> m b) -> m [a] -> m [b]
map3' :: (a -> (b -> r) -> r) -> (([a] -> r) -> r) -> (([b] -> r) -> r)
map3' f cxs =
  cxs >>= (sequence . Prelude.fmap f)

-- map4 :: (m a -> m b) -> [m a] -> m [b]
map4 :: (((a -> r) -> r) -> ((b -> r) -> r)) -> [(a -> r) -> r] -> (([b] -> r) -> r)
map4 f = sequence . Prelude.fmap f

-- this one doesn't make any sense
-- map4' :: (m a -> m b) -> m [a] -> m [b]
-- map4' :: (((a -> r) -> r) -> ((b -> r) -> r)) -> (([a] -> r) -> r) -> (([b] -> r) -> r)
-- map4' = undefined


callCC :: ((a -> ((b -> r) -> r)) -> ((a -> r) -> r)) -> ((a -> r) -> r)
callCC f = \k -> f (\a _ -> k a) k

{-
f :: (a -> (b -> r) -> r) -> (a -> r) -> r

callCC :: ((a -> m b) -> m a) -> m a
let a = Int
callCC :: ((Int -> m b) -> m Int) -> m Int
-}

-- usage examples:

z :: Num t => t
z = -1

q :: forall r. Int -> (Int -> r) -> r
q z k = callCC g k
  where
    g :: forall b. (Int -> (b -> r) -> r) -> (Int -> r) -> r
    g exit c = if (z < 4) then (exit 0 undefined) else (c 9999)

throwIf0 :: forall t b r. (Eq t, Num t) => ((t -> r) -> r) -> (t -> (b -> r) -> r) -> ((t -> r) -> r)
-- exit :: Int -> (b -> r) -> r
throwIf0 cx exit = \k -> cx (\x -> if (x == 0) then (exit 0 undefined) else (k x))

{- -}
um :: forall r. [(Int -> r) -> r] -> (([Int] -> r) -> r)
um cxs = callCC (\exit -> map4 (f exit) cxs)
  where
    f :: forall b. ([Int] -> (b -> r) -> r) -> ((Int -> r) -> r) -> ((Int -> r) -> r)
    f exit cx = \k -> cx (\x -> if (x < 3) then (exit [] undefined) else (k x))
{- -}

{- callCC f
  where
    f :: forall b. (t -> (b -> r) -> r) -> (t -> r) -> r
    f exit = cx (g exit)
    g :: forall c. (t -> c -> r) -> t -> r
    g exit x = if (x Prelude.== 0) then (exit z) else (exit x)
-}

one :: Num t => (t -> r) -> r
one = pure 1

two :: Num t => (t -> r) -> r
two = pure 2

inc :: Num t => ((t -> t) -> r) -> r
inc = \k -> k (Prelude.+ 1)

addthree cx cy cz = (\x y z -> x Prelude.+ y Prelude.+ z) <$> cx <*> cy <*> cz

jsprac.js

// ((a -> r) -> r) -> C r a
function C(f) {
	this.f = f;
}

// C a a -> a
C.prototype.run = function() {
	return this.f(x => x);
};

// (a -> b) -> C r a -> C r b
C.prototype.map = function(f) {
	console.log("C.map -- 0");
	return new C(c => {
		console.log("C.map -- 1");
		return this.f(x => {
			console.log("C.map -- 2");
			return c(f(x));
		})
	});
};

// a -> C r a
function pure(x) {
	console.log("pure -- 0, " + x);
	return new C(k => {
		console.log("pure -- 1", x);
		return k(x);
	});
}

// C r (a -> b) -> C r a -> C r b
function app(cf, cx) {
	console.log("app -- 0");
	return new C(c => {
		console.log("app -- 1");
		return cf.f(k => {
			console.log("app -- 2");
			return cx.f(a => {
				console.log("app -- 3");
				return c(k(a));
			});
		});
	});
}

// C r a -> (a -> C r b) -> C r b
C.prototype.bind = function(f) {
	console.log("bind -- 0");
	return new C(c => {
		console.log("bind -- 1");
		return this.f(x => {
			console.log("bind -- 2");
			return f(x).f(c);
		});
	});
};

var one = pure(1);
var two = pure(2);
function plus(ca, cb) {
	console.log("plus -- 0");
	return ca.bind(a => {
		console.log("plus -- 0");
		return cb.bind(b => {
			console.log("plus -- 0");
			return pure(a + b);
		});
	});
}

// a -> [a] -> [a]
function cons(x, xs) {
	return [x].concat(xs);
}

// TODO overeager ... fixme!
function map(f, xs) {
	console.log("map: " + xs.length + " items " + JSON.stringify(xs))
	if (xs.length === 0) {
		return pure([]);
	}
	var first = xs[0];
	var rest = xs.slice(1);
	return first.bind(y => f(y).bind(z => map(f, rest).bind(zs => pure(cons(z, zs)))));
}

function mapC(f, c) {
	return c.bind(xs => map(f, xs));
}

// C r (Int -> Int)
var inc = pure(x => {
	console.log("inc -- " + x);
	return x + 1;
});

function feg() {
	return map(x => pure(x + 1), [1,2,3,4].map(pure));
}

function fegC() {
	return mapC(x => pure(x + 1), pure([1,2,3,4].map(pure)));
}

// C r Bool -> C r a -> C r a -> C r a
function iff(pred, l, r) {
	console.log("iff -- 0");
	return pred.bind(p => {
		console.log("iff -- 1");
		return p ? l : r;
	});
}

// C r Bool -> C r Bool -> C r Bool
function and(l, r) {
	console.log("and -- 0");
	return iff(l, r, pure(false));
//	return l.bind(x => {
//		console.log("and -- 1");
//		return iff(
}

var spTrue = new C(k => {
	console.log("special true");
	return k(true);
});
var spFalse = new C(k => {
	console.log("special false");
	return k(false);
});

// func and(x, y) { return x && y; }
// eval x
// x true -> eval and return y
// x false -> return false, don't eval y

module.exports = {
	'C'   : C   ,
	'map' : map ,
	'mapC': mapC,
	'pure': pure,
	'app' : app ,
//	'bind': bind,

	'one' : one ,
	'two' : two ,
	'plus': plus,
	'inc' : inc ,
	'and' : and ,

	'iff' : iff ,
	'feg' : feg ,
	'fegC': fegC,
	'spTrue' : spTrue,
	'spFalse': spFalse,
};

/*
callCC :: ((a -> C r b) -> C r a) -> C r a
callCC m = C (\c -> runC (m (\x -> C (\k -> c x))) c)

inc :: C r (Integer -> Integer)
inc = pure (+ 1)

map :: (a -> C r b) -> [C r a] -> C r [b]
map _ [] = pure []
map f (x:xs) =
  x >>= \y ->
  f y >>= \first ->
  map f xs >>= \rest ->
  pure (first : rest)

map :: C r (a -> C r b) -> [C r a]    -> C r [b]
map 

map :: (a -> C r b)     -> Cr [C r a] -> C r [b]
map f ys =
  ys >>= \xs ->
    case xs of
      [] -> pure []
      (z:zs) -> z >>= \first -> map f zs >>= \rest -> pure (first : rest)
      

map :: C r (a -> C r b) -> Cr [C r a] -> C r [b]


-- throw :: (a -> C r b) -> C r a
-- (a -> (b -> r) -> r) -> (a -> r) -> r
-- throw f = C (\c -> 

-- p :: Integer -> (Integer -> C r ) -> C r [Integer]
-- p z f = C (\c -> if (z > 5) then 

-- callC
-- cEG :: Integer -> C r Integer 
-- cEG z = callCC f >>= \xs -> pure xs
--  where f k = if (z > 5) then (pure [3]) else [k z, k z, k (z + 1)]

when :: Bool -> C r () -> C r ()
-- Bool -> ((U -> r) -> r) -> ((U -> r) -> r)
when pred (C cont) = C (\k -> if pred then (cont k) else k ())


when2 :: Bool -> [()] -> [()]
when2 pred xs = if pred then xs else []

cEG x = callCC (\exit -> when (x > 5) (pure ()) >> pure 8)

iff :: C r Bool -> C r a -> C r a -> C r a
-- ((Bool -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r)
iff pred (C a) (C b) = pred >>= \p -> C (\k -> if p then (a k) else (b k))

iff2 :: C r Bool -> C r a -> C r a -> C r a
-- ((Bool -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r)
iff2 pred a b = pred >>= \p -> if p then a else b

{-
foldr :: C r (a -> b -> C r b) -> C r b -> [C r a] -> C r b
foldr _ b [] = b
foldr cf cb (x:xs) =
  cf >>= \f ->
  cb >>= \b -> 
  cxs >>= \xs -> f x b-}
-- 
foldr2 :: (a -> b -> b) -> b -> [a] -> b
foldr2 _ b [] = b
foldr2 f b (x:xs) = f x (foldr2 f b xs)

foldl :: (b -> a -> b) -> b -> [] a -> b
foldl _ b [] = b
foldl f b (x:xs) = foldl f (f b x) xs
*/

prac.hs

{-# LANGUAGE GADTs, ScopedTypeVariables, Rank2Types #-}

import Prelude hiding (map, foldr, foldl)
-- import Prelude
import qualified Prelude

newtype C r a = C { runC :: (a -> r) -> r }

-- just for help debugging
instance Show (C r a) where
  show c = "<continuation>"

instance Functor (C r) where
  fmap f (C m) = C (\c -> m (c . f))

instance Applicative (C r) where
  pure x = C (flip ($) x)
  C f <*> C x = C (\c -> f (\k -> x (c . k)))

instance Monad (C r) where
  C m >>= f = C (\c -> m (\x -> runC (f x) c))

callCC :: ((a -> C r b) -> C r a) -> C r a
callCC m = C (\c -> runC (m (\x -> C (\k -> c x))) c)

-- maybe this just does a better job of emphasizing that callCC
-- really doesn't know or care what type `b` is ... ?
callCC2 :: forall r a. ((forall b. a -> C r b) -> C r a) -> C r a
callCC2 m = C (\c -> runC (m (\x -> C (\k -> c x))) c)

liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
liftA2 f a b = (fmap f a) <*> b

join :: Monad m => m (m a) -> m a
join mm = mm >>= id


one :: Num t => C r t
one = pure 1

two :: Num t => C r t
two = pure 2

inc :: Num t => C r (t -> t)
inc = pure (+ 1)

inc' :: Num t => t -> C r t
inc' = pure . (1 +)

plus :: Num t => C r t -> C r t -> C r t
plus = liftA2 (+)


run :: C a a -> a
run c = runC c id

run' :: C r a -> (a -> r) -> r
run' c f = runC c f


data Seq r a where
  Nil :: Seq r a
  Cons :: C r (a, Seq r a) -> Seq r a
  deriving (Show)

runS :: Seq r a -> C r [a]
runS Nil = pure []
runS (Cons c) =
  c >>= \(x, cs) ->
  runS cs >>= \xs ->
  pure (x:xs)

runS2 :: Seq r a -> ([a] -> r) -> r
-- runS2 s f = runC (runS s) f
runS2 = runC . runS

runS3 :: C r (Seq r a) -> ([a] -> r) -> r
runS3 c f = runC (join (fmap runS c)) f

seqEg :: [Int]
seqEg = runS3 (mapS inc' (makeSeq [1..5])) id

cons :: a -> Seq r a -> Seq r a
cons head seq = Cons (pure (head, seq))

makeSeq :: [a] -> Seq r a
makeSeq [] = Nil
makeSeq (x:xs) = cons x (makeSeq xs)

cons2 :: C r a -> Seq r a -> Seq r a
cons2 head seq = Cons (head >>= \x -> pure (x, seq))

mapS :: (a -> C r b) -> Seq r a -> C r (Seq r b)
mapS _ Nil = pure Nil
mapS f (Cons s) =
  s >>= \(x, cs) ->
  f x >>= \y ->
  mapS f cs >>= \ys ->
  pure (Cons (pure (y, ys)))
-- alt:  s >>= \(x, cs) -> (\y ys -> Cons (pure (y, ys))) <$> f x <*> mapS f cs
-- alt2: s >>= \(x, cs) -> (\y -> Cons . pure . (y,)) <$> f x <*> mapS f cs

mapS' :: forall r a b. C r (a -> b) -> Seq r a -> C r (Seq r b)
mapS' _ Nil = pure Nil
mapS' cf (Cons s) = cons2 (cf <*> fmap fst s) <$> join (mapS' cf <$> fmap snd s)

(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
l >=> r = \x -> l x >>= r


q1 :: (a -> b) -> a -> b
q1 f a = f a
q2 :: Applicative m => m (a -> b) -> m a -> m b
q2 f a = f <*> a
q3 :: Monad m => (a -> m b) -> m a -> m b
q3 f a = a >>= f

q4 :: (a -> (b -> c)) -> a -> b -> c
q4 f a b = (f a) b
q5 :: Applicative m => m (a -> b -> c) -> m a -> m b -> m c
q5 f a b = f <*> a <*> b
q6 :: Monad m => (a -> m (b -> c)) -> m a -> m b -> m c
q6 f a b = (a >>= f) <*> b
q7 :: Monad m => (a -> m (b -> m c)) -> m a -> m b -> m c
q7 f a b = join ((a >>= f) <*> b)


-- a -> b
-- a -> m m
-- a -> b -> c
-- a -> (b -> c)
-- a -> m (b -> c)
-- a -> m (b -> m c)
crush :: Monad m => (a -> m (b -> m c)) -> a -> b -> m c
crush m x y = m x >>= \f -> f y
-- data L a
--  = N          -- :: L a
--  | C a (L a)  -- :: a -> L a -> L a

data List r a
  = Empty
  | Pair (C r a) (C r (List r a))
--  | Pair (C r a (C r a, C r (List r a)))
  deriving (Show)

-- map f (x:xs) = f x : map f xs
-- mapSeq _ Empty = pure Empty
-- mapSeq cf (Pair cx cxs) = Pair <$> (cf <*> cx) <*> (mapSeq <*> cf <*> cxs)
-- mapSeq :: C r (a -> b) -> List r a -> List r b
-- mapSeq cf (Pair cx cxs) = Pair (cf <*> cx) (mapSeq <*> cf <*> cxs)

mapQ :: (a -> C r b) -> [C r a] -> C r [b]
mapQ f = sequence . fmap join . fmap (fmap f)

mapQ' :: C r (a -> b) -> [C r a] -> C r [b]
mapQ' _ [] = pure []
mapQ' cf (cx:cxs) = (:) <$> (cf <*> cx) <*> (mapQ' cf cxs)

map2 :: (a -> C r b) -> C r [C r a] -> C r [b]
-- map2 f c = join (c >>= \z -> mapQ f z)
map2 f c = c >>= mapQ f


-- throw :: (a -> C r b) -> C r a
-- (a -> (b -> r) -> r) -> (a -> r) -> r
-- throw f = C (\c ->

-- p :: Integer -> (Integer -> C r ) -> C r [Integer]
-- p z f = C (\c -> if (z > 5) then

-- callC
-- cEG :: Integer -> C r Integer
-- cEG z = callCC f >>= \xs -> pure xs
--  where f k = if (z > 5) then (pure [3]) else [k z, k z, k (z + 1)]

when :: Applicative m => Bool -> m () -> m ()
-- Bool -> ((U -> r) -> r) -> ((U -> r) -> r)
-- when pred (C cont) = C (\k -> if pred then (cont k) else k ())
when pred c =
  if pred
  then c
  else pure ()

when' :: Applicative m => Bool -> m a -> m ()
when' pred c = when pred (c *> pure ())

when2 :: Bool -> [()] -> [()]
when2 pred xs = if pred then xs else []


-- callCC :: ((a -> C r b) -> C r a) -> C r a
-- mapQ :: (a -> C r b) -> [C r a] -> C r [b]
-- (([Int] -> C r b) -> C r [Int]) -> C r [Int]
{-
poop :: C r [Int]
poop = callCC g
  where
    g :: ([Int] -> C r ()) -> C r [Int]
    g exit = mapQ (f exit) nums
    nums :: [C r Int]
    nums = fmap pure [1..5]
    f :: ([Int] -> C r ()) -> [Int] -> C r ()
    f e xs = if (length xs < 3) then (pure ()) else (e xs)
-}

str :: (Show s, Foldable m, Functor m) => m s -> String
str = Prelude.foldr (++) "" . fmap show

poop :: Int -> C r String
poop limit =
  callCC (\exit ->
  pure 1 >>= \x ->
    if x > limit
    then ((exit "oops ???") *> exit "oops -- 2!")
    else
      pure 2 >>= \y ->
        if y > limit
        then (exit "oops, y")
        else pure 3 >>= \z ->
          if z > limit
          then (exit "oops, z")
          else pure (str [x, y, z]))
--  pure 3 >>= \z -> pure (str [x, y, z])
--  pure 4 >>= \a -> pure (str [x, y, z, a]))

whileCount :: Int -> C r [Int]
whileCount limit = callCC (\exit -> go exit 0 [])
  where
    go e n xs
      | n >= limit = e xs
      | otherwise = go e (n + 1) (n:xs)

w initial pred inc = callCC (\exit -> go exit initial pred inc)
go e state pred inc
  | pred state = go e (inc state) pred inc
  | otherwise = e state

-- callCC :: ((a -> C r b) -> C r a) -> C r a
while :: forall r a. a -> (a -> Bool) -> (a -> a) -> C r a
while initial pred inc = callCC (\exit -> go exit initial)
  where
    go :: (a -> C r a) -> a -> C r a
    -- or: go :: (m -> n) -> m -> n   (except that closing over `pred` and `inc` forces our hand)
    go e state
      | pred state = go e (inc state)
      | otherwise = e state

whileEg :: C r (Int, [Int])
whileEg = while (0, []) (\(n, _) -> n < 3) (\(n, xs) -> (n + 1, n:xs))


whatsYourName :: String -> String
whatsYourName name = runC (callCC f) id
  where f exit = validateName name exit *> pure ("Welcome, " ++ name ++ "!")

validateName :: (Applicative m, Foldable t) => t a -> (String -> m ()) -> m ()
validateName name exit =
  when (null name) (exit "You forgot to tell me your name!")


cEG x = callCC (\exit -> when (x > 5) (pure ()) >> pure 8)

iff :: C r Bool -> C r a -> C r a -> C r a
-- ((Bool -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r)
iff pred (C a) (C b) = pred >>= \p -> C (\k -> if p then (a k) else (b k))

iff2 :: C r Bool -> C r a -> C r a -> C r a
-- ((Bool -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r) -> ((a -> r) -> r)
iff2 pred a b = pred >>= \p -> if p then a else b

{-
foldr :: C r (a -> b -> C r b) -> C r b -> [C r a] -> C r b
foldr _ b [] = b
foldr cf cb (x:xs) =
  cf >>= \f ->
  cb >>= \b ->
  cxs >>= \xs -> f x b -}
--
foldr2 :: (a -> b -> b) -> b -> [a] -> b
foldr2 _ b [] = b
foldr2 f b (x:xs) = f x (foldr2 f b xs)

foldl :: (b -> a -> b) -> b -> [] a -> b
foldl _ b [] = b
foldl f b (x:xs) = foldl f (f b x) xs

map3 :: (a -> C r b)     -> C r [C r a] -> C r [b]
map3 f ys =
  ys >>= \xs ->
    case xs of
      [] -> pure []
      (z:zs) -> z >>= \q -> f q >>= \first -> map3 f (pure zs) >>= \rest -> pure (first : rest)


-- map4 :: (C r a -> C r b) -> [C r a] -> C r [b]
-- map4 :: (((a -> r) -> r) -> ((b -> r) -> r)) -> [(a -> r) -> r] -> (([b] -> r) -> r)
map4 f = sequence . fmap f

-- TODO not sure what's a good name for this -- this has got to already be on Hoogle though
branch :: Monad m => m a -> (a -> Bool) -> m a -> m a
branch cx pred false = cx >>= \x -> if (pred x) then false else (pure x)

abortIfElemLessThan3 :: forall r. [C r Int] -> C r [Int]
abortIfElemLessThan3 cxs = callCC (\exit -> map4 (f $ exit []) cxs)
  where
    f :: C r Int -> C r Int -> C r Int
    -- f exit cx = cx >>= (\x -> if (x < 3) then exit else (pure x))
    -- um :: (a -> m Bool) -> m a
    -- um :: m a -> (a -> Bool) -> m a
    -- f exit cx = um cx (\x -> if (x < 3) then exit else pure ())
    f exit cx = branch cx (\x -> x < 3) exit

square :: Int -> C r Int
square n = callCC $ \k -> k (n ^ 2)

um :: forall r. Int -> C r Int
um x = callCC (\success -> callCC (\failure -> g (success x) (failure 0)))
  where
    g :: forall a. C r a -> C r a -> C r a
    g success failure = if (x < 3) then failure else success

um2 :: forall r. Int -> C r (Either String Int)
um2 x = callCC (\success -> callCC (\failure -> g success failure))
  where
    g :: (Either String Int -> C r (Either String Int)) -> (Either String Int -> C r (Either String Int)) -> C r (Either String Int)
    g success failure = if (x < 3) then (failure $ Left "oops") else (success $ Right x)

um3 :: forall r. Int -> C r (Either String Int)
um3 x = callCC (\success -> callCC (\failure -> g (success . Right) (failure . Left)))
  where
    g :: forall a. (Int -> C r a) -> (String -> C r a) -> C r a
    g success failure = if (x < 3) then (failure "oops") else (success x)

-- try :: ((e -> m a) -> m a) -> (e -> m a) -> m a
-- try :: ((e -> (a -> r) -> r) -> (a -> r) -> r) -> (e -> (a -> r) -> r) -> ((a -> r) -> r)
-- try c h = callCC (\ok -> callCC (\notOk -> c notOk >>= ok) >>= h)
try :: forall r e a. ((e -> C r a) -> C r a) -> (e -> C r a) -> C r a
try c h = callCC f
  where
    -- callCC :: ((a -> C r b) -> C r a) -> C r a
    f :: (a -> C r e) -> C r a
    f ok = callCC (g ok) >>= h
    g :: (a -> C r e) -> (e -> C r a) -> C r e
    g ok notOk = c notOk >>= ok

types.go

package main

import (
  "fmt"
)

type Layer interface {
  Type() string
}

type Id struct {
  BaseType string
}

func (i *Id)Type() string {
//  return fmt.Sprintf("Id %s", i.BaseType)
  return i.BaseType
}

type List struct {
  BaseType Layer
}

func (l *List)Type() string {
  return fmt.Sprintf("[%s]", l.BaseType.Type())
}

type Cont struct {
  ResultType string
  BaseType Layer
}

func (c *Cont)Type() string {
  return fmt.Sprintf("((%s -> %s) -> %s)", c.BaseType.Type(), c.ResultType, c.ResultType)
}

type Reader struct {
  EnvType string
  BaseType Layer
}

func (r *Reader)Type() string {
  return fmt.Sprintf("(%s -> %s)", r.EnvType, r.BaseType.Type())
}

type Error struct {
  ErrorType string
  BaseType Layer
}

func (e *Error)Type() string {
  return fmt.Sprintf("(Error %s %s)", e.ErrorType, e.BaseType.Type())
}

type Maybe struct {
  BaseType Layer
}

func (m *Maybe)Type() string {
  return fmt.Sprintf("(Maybe %s)", m.BaseType.Type())
}

type State struct {
  StateType string
  BaseType Layer
}

func (s *State)Type() string {
  return fmt.Sprintf("(%s -> (%s, %s))", s.StateType, s.StateType, s.BaseType.Type())
}

type Writer struct {
  LogType string
  BaseType Layer
}

func (w *Writer)Type() string {
  return fmt.Sprintf("(%s, %s)", w.LogType, w.BaseType.Type())
}

// TODO tree


func main() {
  types := []Layer{
    &List{&Id{"Int"}},
    &Cont{"r", &Id{"Int"}},
    &Reader{"r", &Id{"Int"}},
    &Error{"e", &Id{"a"}},
    &Maybe{&Id{"a"}},
    &Writer{"w", &Id{"a"}},
    &State{"s", &Id{"a"}},
    &List{&List{&Id{"Int"}}},
    &Reader{"env", &Cont{"r", &Id{"String"}}},
    &Cont{"r1", &Cont{"r2", &Id{"a"}}},
    &State{"s", &Error{"e", &Maybe{&Id{"a"}}}},
  }
//  var t = List{&List{&Id{"Int"}}}
  for _, t := range types {
    fmt.Printf("%s\n", t.Type())
  }
}