Finally Tagless Monads

Unmonad.hs

import Data.Monoid

type State s a = s -> (a,s)

get :: State s s
set :: s -> State s ()

get s = (s,s)
set s _ = ((),s)

infixl 5 `bindS`
bindS :: State s a -> (a -> State s b) -> State s b
bindS f k s = let ~(a,s') = f s in k a s'
returnS :: a -> State s a
returnS a s = (a,s)

type Reader e a = e -> a

ask :: Reader e e
local :: e -> Reader e a -> Reader e a
ask e = e
local e r _ = r e

infixl 5 `bindR`
bindR :: Reader e a -> (a -> Reader e b) -> Reader e b
returnR :: a -> Reader e a
bindR f k e = let a = f e in k a e
returnR a _ = a

type Writer w a = (w,a)

put :: w -> Writer w ()
put w = (w,())
collect :: (Monoid w) => Writer w a -> Writer w w
collect (w,_) = returnW w

infixl 5 `bindW`
bindW :: (Monoid w) => Writer w a -> (a -> Writer w b) -> Writer w b
returnW :: (Monoid w) => a -> Writer w a
bindW ~(w,a) k = let ~(w',b) = k a in (mappend w w',b)
returnW a = (mempty,a)

type Exceptional x a = Either x a

throw :: x -> Exceptional x a
throw x = Left x
try :: Exceptional x a -> Exceptional x (Either x a)
try m = returnX m

infixl 5 `bindX`
bindX :: Exceptional x a -> (a -> Exceptional x b) -> Exceptional x b
returnX :: a -> Exceptional x a
bindX (Left x) _  = Left x
bindX (Right a) k = k a
returnX a = Right a

type Cont r a = (a -> r) -> r

halt :: r -> Cont r a
halt r _ = r
callCC :: ((a -> Cont r b) -> Cont r a) -> Cont r a
callCC f k = f (\a _ -> k a) k

infixl 5 `bindC`
bindC :: Cont r a -> (a -> Cont r b) -> Cont r b
returnC :: a -> Cont r a
bindC a k c = a (flip k c)
returnC a k = k a

newtype Lab r a = Lab ((a,Lab r a) -> Cont r ())
label :: a -> Cont r (a,Lab r a)
label a = callCC $ \k -> returnC (a,Lab k)
jump :: Lab r a -> a -> Cont r a
jump (Lab k) a = k (a,Lab k) `bindC` error "unreachable"