Scheme style co-routine implemented in ContT

[zhou...@163.com]

When I program in Frege, I really miss Scheme style co-routine. I put much effort learning Haskell although I still feel dizzy about Monad Transformer. At this moment I start to believe Frege's potential of doing such thing, forget about the code quality, I just want to proof of concept

[zhou...@163.com]

Source code is there, can be loaded by Frege Repl 3.24.100

module examples.MyCont where

import frege.control.monad.State

import Data.Char

import Control.Concurrent as C

class MonadIO m where

  --- Lift a computation from the 'IO' monad.

  liftIO :: IO a -> m a

class MonadTrans t where

  --- Lift a computation from the argument monad to the constructed monad.

  lift :: Monad m => m a -> t m a

instance MonadIO IO where

  liftIO io = io

instance MonadTrans (ContT r) where

    lift m = ContT (m >>=)

instance (Monad m, MonadIO m) => MonadIO (ContT r m) where

    liftIO = lift . liftIO

data ContT r m a = ContT { runContT :: (a -> m r) -> m r }

instance Functor (ContT r m) where

  fmap f m = ContT $ \c -> ContT.runContT m (c . f)

instance Applicative (ContT r m) where

  pure x = ContT ($ x)

  f <*> v = ContT $ \c -> ContT.runContT f $ \g -> ContT.runContT v (c . g)

  m *> k = m >>= \_ -> k

instance Monad (ContT r m) where

  pure x = ContT ($ x)

  m >>= k = ContT $ \c -> ContT.runContT m (\x -> ContT.runContT (k x) c)

callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a

callCC f = ContT $ \c -> ContT.runContT (f (\a -> ContT $ \_ -> c a)) c

data Date = native java.util.Date where

  native new :: () -> IO (MutableIO Date)

  native toString :: Mutable s Date -> ST s String

current :: IO String

current = do

  d <- Date.new ()

  d.toString

runContT = ContT.runContT

spawn = callCC $ \k -> do

  lift $ putStrLn "begin capture current continuation ..."

  (r, s) <- callCC $ \next -> do

    callCC $ \k2 -> do

      let f x = k2 (f, x)

      k (f, "jump to 1")

  lift $ putStrLn ("can we be here1? -- " ++ s)

  (r, s) <- callCC $ \next -> do

    callCC $ \k2 -> do

      let f x = k2 (f, x)

      k (f, "jump to 2")

  lift $ putStrLn ("can we be here2? -- " ++ s)

  (r, s) <- callCC $ \next -> do

    callCC $ \k2 -> do

      let f x = k2 (f, x)

      k (f, "jump to 3")

  lift $ putStrLn ("can we be here3? -- " ++ s)

  return (r, s)

fun1 = (`runContT` return) $ do

  lift $ putStrLn "alpha"

  (k, s) <- spawn

  lift $ putStrLn ("in fun1 -- " ++ s)

  lift $ Thread.sleep (2000L)

  k "I try to pass some string here"

  lift $ putStrLn "no chance to be there"

[zhou...@163.com]

Refactor my code, in fact I should name the code "wing man", they help each other to accomplish the job.

spawn = callCC $ \k -> do

  let suspend = callCC $ \c -> do

                  let f x = c (f, x)

                  k (f, "ready!")

  lift $ putStrLn "begin capture current continuation ..."

  (r, s) <- suspend

  lift $ putStrLn ("can we be here1? -- " ++ s)

  (r, s) <- suspend

  lift $ putStrLn ("can we be here2? -- " ++ s)

  (r, s) <- suspend

  lift $ putStrLn ("can we be here3? -- " ++ s)

  return (r, "kkkk")

wingman = (`runContT` return) $ do