Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

75 lines (56 sloc) 2.319 kb
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- | An example implementation of the lovely continuation monad.
module Cont where
import Language.Fay.FFI
import Language.Fay.Prelude
--------------------------------------------------------------------------------
-- Entry point.
-- | Main entry point.
main :: Fay ()
main = runContT demo (const (return ()))
demo :: Deferred ()
demo = case contT of
CC return (>>=) (>>) callCC lift -> do
lift (print "Hello!")
sync setTimeout 500
contents <- sync readFile "README.md"
lift (print ("File contents is: " ++ take 10 contents ++ "..."))
--------------------------------------------------------------------------------
-- Deferred library.
-- | An example deferred monad.
type Deferred a = ContT () Fay a
-- | Set an asynchronous timeout.
setTimeout :: Int -> (() -> Fay ()) -> Fay ()
setTimeout = ffi "global.setTimeout(%2,%1)"
readFile :: Foreign b => String -> (String -> Fay b) -> Fay b
readFile = ffi "require('fs').readFile(%1,'utf-8',function(_,s){ %2(s); })"
-- | Print using console.log.
print :: String -> Fay ()
print = ffi "console.log(%1)"
sync :: (t -> (a -> Fay r) -> Fay r) -> t -> ContT r Fay a
sync m a = ContT $ \c -> m a c
--------------------------------------------------------------------------------
-- Continuation library.
-- | The continuation monad.
data ContT r m a = ContT { runContT :: (a -> m r) -> m r }
instance (Monad m) => Monad (ContT r m)
data CC = CC
{ cc_return :: forall a r. a -> ContT r Fay a
, cc_bind :: forall a b r. ContT r Fay a -> (a -> ContT r Fay b) -> ContT r Fay b
, cc_then :: forall a b r. ContT r Fay a -> ContT r Fay b -> ContT r Fay b
, cc_callCC :: forall a b r. ((a -> ContT r Fay b) -> ContT r Fay a) -> ContT r Fay a
, cc_lift :: forall a r. Fay a -> ContT r Fay a
}
-- | The continuation monad module.
contT =
let return a = ContT (\f -> f a)
m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)
m >> n = m >>= \_ -> n
callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c
lift m = ContT (\x -> m >>=* x)
in CC return (>>=) (>>) callCC lift where (>>=*) = (>>=)
--------------------------------------------------------------------------------
-- Crap.
take 0 _ = []
take n (x:xs) = x : take (n-1) xs
Jump to Line
Something went wrong with that request. Please try again.