Yield: Mainstream Delimited Continuations - https://legacy.cs.indiana.edu/~sabry/papers/yield.pdf

Yield - as in James and Sabry.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages(p: with p; [])"
#! nix-shell -I nixpkgs=channel:nixos-20.9

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module CCYield4 where

import Control.Monad

-- - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Iterator : language interieur, avec yield

data Iterator i o r -- Free Susp
  = Result r
  | Susp o (i -> Iterator i o r)

instance Functor (Iterator i o) where
  fmap = liftM

instance Applicative (Iterator i o) where
  pure = return
  (<*>) = ap

instance Monad (Iterator i o) where
  return = Result
  x >>= f = case x of
    Result r -> f r
    Susp o k -> Susp o (k >=> f)

-- - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
--- Yield avec controle naturel

-- forall a m. Monad m => m a == forall r. (a -> m r) -> m r
newtype Yield i o r = Yield {unY :: forall b. (r -> Iterator i o b) -> Iterator i o b}

instance Functor (Yield i o) where
  fmap = liftM

instance Applicative (Yield i o) where
  pure = return
  (<*>) = ap

instance Monad (Yield i o) where
  return x = Yield (\k -> k x)
  (Yield e) >>= f = Yield (\k -> e (\v -> unY (f v) k))

yield x = Yield (\k -> Susp x k) --- rajoute un tour dans l'isomorphisme

run (Yield e) = e Result

-- - -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Exemple
data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Show)

depthWalk (Node l r) = do
  l' <- depthWalk l
  r' <- depthWalk r
  return (Node l' r')
depthWalk (Leaf a) = do
  b <- yield a
  return (Leaf b)

renum :: (o ~ Int, i ~ Int) => Iterator i o (Tree i) -> Tree i
renum (Result t) = t
renum (Susp n k) = renum (k (n + 1))

main :: IO ()
main =
  do
    let tree = Node (Node (Leaf 3) (Leaf 5)) (Leaf 6)
    let tree' = run (depthWalk tree) |> renum
    putStrLn "Original tree :"
    print tree
    putStrLn "New tree :"
    print tree'


loop f m = each (run m)
  where
    each (Susp x k) = each (k (f x))
    each (Result r) = r

renum' = loop (1 +)

(|>) :: a -> (a -> b) -> b
x |> f = f x