Examples of the Cont monad.
Actually we stack up other monad transformers on it for interesting things
such as state. We do it like StateT s (Cont y), although we get similar
behaviour with ContT y (State s) because instance lifting code is
written to commute them.

> import Control.Monad.Cont
> import Control.Monad.State.Strict
> import Control.Monad.Reader
> import Control.Monad

Basic principle.

callCC :: ((a -> m b) -> m a) -> m a
Or, 3rd-rank polymorphic implementation ((forall b. a -> m b) -> m a) -> m a)

x <- callCC (\c -> .... c x1 ... return x0)

In this code, c :: a -> m b and x0,x1,x :: a

Think of c x1 as an action for early exit.
If execution hits c x1, we exit early and x becomes x1.
Otherwise, normal exit means x becomes x0.
Note that c x1 :: m b with unconstrained b, so it can blend into its context.
(Clearly, it doesn't really return a value of type b; execution jumps
elsewhere and this is just type checking.)

In this example, starting from initial state n, the loop increases it
until the state becomes 5, then exits and returns that value. Note
that c s :: m () to satisfy the type of when.

> loop :: (Monad m) => m a -> m b
> loop p = fix (p >>)

> fun :: Int -> Int
> fun n = runCont (evalStateT p n) id
>     where
>       p = do
>         { callCC $ \c -> loop $ do
>                               { modify (+ 1)
>                               ; s <- get
>                               ; when (s == 5) (c s)
>                               }
>         }


This example is more advanced. Can we "leak" c to the outer scope and
use it elsewhere? Yes.

c still needs to be applied to some argument, let's call that x for
now. (We will solve for x soon.) It's more convenient to return c x,
and the user just needs to bind it to l and execute it later. When
c x is executed, execution jumps back to its callCC origin, and x is
returned and bound to the user's l, and it should be c x again so that
the whole thing is repeatable. Therefore we have x = c x = fix c.

Typing: l, fix c :: m b, c :: m b -> m b. In this example b = Int by
blending into the if-then-else.

> setjmp :: (MonadCont m) => m (m b)
> setjmp = callCC (\c -> return (fix c))

> jumpy :: Int -> Int
> jumpy n = runCont (evalStateT p n) id
>     where
>       p = do
>         { l <- setjmp
>         ; modify (+ 1)
>         ; s <- get
>         ; if s == 5 then return s else l
>         }


Exception throwing and handling is a close cousin of callCC. Here we
implement it. The action to be protected needs to know how to throw an
exception; here we assume it takes a thrower as a parameter, and it
calls the provided thrower when it wants to. Inside callCC, which
provides c, we can define the thrower to run a handler and then use c
to exit early; now we can run the action with this thrower.

We use this to take square roots repeatedly of the state until it is
close enough to 1; for states 0 or negative, we throw an exception,
and the handler returns 0 or NaN respectively.

> catchC :: (MonadCont m) =>
>           ((e -> m b) -> m a)  -- action, takes a thrower parameter
>        -> (e -> m a)           -- handler
>        -> m a
> catchC action handler = callCC (\c -> action (\e -> handler e >>= c))

> data Bad = Zero | Neg deriving Show

> catchme :: Double -> Double
> catchme n = runCont (evalStateT p n) id
>     where
>       p = do
>         { catchC q handler
>         }
>       q throw = do
>         { s <- get
>         ; when (s < 0) (throw Neg)
>         ; when (s <= 0) (throw Zero)
>         ; l <- setjmp
>         ; t <- get
>         ; if abs(t - 1) < 0.01 then return t else modify sqrt >> l
>         }
>       handler Zero = return 0
>       handler Neg = return (sqrt (-1))

It is bothersome to mandate every protected action to take a thrower
parameter. Now we tag on a ReaderT layer to make throwers implicit.
As a bonus we also get to install a "top level" handler.

Doing this introduces an infinite type. (The monad is a MonadReader of
the thrower, and the thrower mentions that monad again.) A lightweight
way of untying this is to be specific about our monad stack (RSC
below) and newtyping the thrower. There are more advanced solutions.

> type RSC e s y = ReaderT (Thrower e s y) (StateT s (Cont y))
> newtype Thrower e s y = Thrower (e -> RSC e s y ())

The throw command throwI asks for the thrower from the environment
and executes it.

The thrower returns (). The throw command returns an arbitrary b to
blend into its caller context. This gap can be bridged by appending a
meaningless polymorphic action after the thrower. (Alternative
solution: the Thrower type is Thrower (forall b. e -> RSC e s y b),
and callCC needs to be 2nd-rank too.)

> throwI :: e -> RSC e s y b
> throwI e = do
>   { Thrower thrower <- ask
>   ; thrower e
>   ; undefined
>   }

The catch command catchI constructs the new thrower from the handler
and uses it as the new environment for running the action. The thrower
calls the handler and then jumps outside, as in the previous example. But
in addition the handler needs to be arranged to run under the old
environment so that it can "re-throw" exceptions. (If we don't code
this up, the handler is run under the new environment (because it's
called by the action under the new environment), and re-throwing
causes looping.) This is seamlessly done with "local", which not only
shadows the old environment, but also lets us map from the old to the
new, so we can actually say we are constructing the new thrower from
the old.

> catchI :: RSC e s y a
>        -> (e -> RSC e s y a)
>        -> RSC e s y a
> catchI action handler =
>     callCC (\c -> local (mkt c) action)
>     where mkt c r = Thrower (\e -> with r (handler e >>= c))
>           with r m = local (const r) m

This example usage takes square roots of the state until it's close to
1. For 0 or negative states, we throw an exception. Like the previous
example, in the 0 case we return 0. Unlike the previous example, in
the negative case we re-throw the exception to demonstrate that
re-throwing works its way to the outer handler.

> exceptional :: Double -> Double
> exceptional n = runCont (evalStateT (runReaderT p topthrow) n) id
>     where
>       topthrow = Thrower (\e -> error ("unhandled exception " ++ show e))
>       p = do
>         { catchI q handler
>         }
>       q = do
>         { s <- get
>         ; when (s < 0) (throwI Neg)
>         ; when (s <= 0) (throwI Zero)
>         ; l <- setjmp
>         ; t <- get
>         ; if abs(t - 1) < 0.01 then return t else modify sqrt >> l
>         }
>       handler Zero = return 0
>       handler Neg = throwI Neg

> {-
> class (MonadCont m) => MonadCont2 m where
>     callCC2 :: ((forall b. a -> m b) -> m a) -> m a

> instance (Monad m) => MonadCont2 (ContT r m) where
>     callCC2 f = ContT (\c -> runContT (f (\a -> ContT (\_ -> c a))) c)
> -}