Haskell/Continuation passing style

cont-01.hs

-- https://en.wikibooks.org/wiki/Haskell/Continuation_passing_style

add :: Int -> Int -> Int
add x y = x + y

square :: Int -> Int
square x = x * x

pithagoras :: Int -> Int -> Int
pithagoras x y = add (square x) (square y)

add_cps :: Int -> Int-> (Int -> r) -> r
add_cps x y = \k -> k $ add x y

square_cps :: Int -> (Int -> r) -> r
square_cps x = \k -> k $ square x

pithagoras_cps :: Int -> Int-> (Int -> r) -> r
pithagoras_cps x y = \k ->
  square_cps x $ \x_squared ->
  square_cps y $ \y_squared ->
  add_cps x_squared y_squared $ k

t1 = pithagoras_cps 3 4 $ print

thrice :: (a -> a) ->  a -> a
thrice f = f . f . f

thrice_cps :: (a -> (a -> r) -> r) -> a -> (a -> r) -> r
thrice_cps f x = \k ->
  f x   $ \fx  ->
  f fx  $ \ffx ->
  f ffx $ k

tail_cont :: [a] -> ([a] -> r) -> r
tail_cont xs = \k -> k $ tail xs

t2 = thrice_cps tail_cont "thrice" $ print

cont-02.hs

ka :: (Int -> r) -> r
ka = ($ 42)
-- ka f = \f -> f 42

fk :: Int -> (Bool -> r) -> r
fk x = \k -> k $ mod x 2 == 0

chainCPS :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r)
-- chainCPS ka fk = error "todo" {- :t chainCPS ka fk results in (Bool -> r) -> r -}
chainCPS ka fk = \k -> ka $ \a -> fk a k

t1 :: IO ()
t1 = chainCPS ka fk print

cont-03.hs

import Control.Monad

newtype Cont r a = Cont {runCont :: (a -> r) -> r}

cont :: ((a -> r) -> r) -> Cont r a
cont ka = Cont ka

instance Monad (Cont r) where
  -- return x = Cont $ \c -> c x
  -- (Cont c) >>= f = Cont $ \k -> c (\a -> runCont (f a) k)
  -- return x = cont ($ x)
  return = cont . flip ($)
  -- chainCPS :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r)
  -- chainCPS ka fk = \k -> ka $ \a -> fk a k
  -- (Cont ka) >>= f = cont $ \k -> ka $ \a -> runCont (f a) k
  s >>= f = cont $ \k -> runCont s $ \a -> runCont (f a) k

instance Applicative (Cont r) where
  pure = return
  (<*>) = ap

instance Functor (Cont r) where
  fmap = liftM

------------------------------
add :: Int -> Int -> Int
add x y = x + y

square :: Int -> Int
square x = x * x

pithagoras :: Int -> Int -> Int
pithagoras x y = add (square x) (square y)

add_cps :: Int -> Int-> (Int -> r) -> r
add_cps x y = \k -> k $ add x y

square_cps :: Int -> (Int -> r) -> r
square_cps x = \k -> k $ square x
------------------------------
square_cont :: Int -> (Cont r Int)
square_cont = cont . square_cps

add_cont :: Int -> Int -> (Cont r Int)
add_cont x y = cont $ add_cps x y

pithagoras_cont :: Int -> Int -> (Cont r Int)
pithagoras_cont x y = do
  x2 <- square_cont x
  y2 <- square_cont y
  add_cont x2 y2

t1 = runCont (square_cont 5) print
t2 = runCont (add_cont 3 4) print
t3 = runCont (pithagoras_cont 3 4) print