Experience reports using indexed monads in production?

Question

In a previous question I discovered the existence of Conor McBride\'s Kleisli arrows of Outrageous Fortune while looking for ways of encoding Idris examples in Haskell. My effor

Answer 1

Another nice example is mutexes with lock-unlock check at compile time. You can find this example on Stephen Diehl website:

http://dev.stephendiehl.com/hask/#indexed-monads

Answer 2

I think the below should count as a practical example: statically enforcing "well-stackedness" in a compiler. Boilerplate first:

{-# LANGUAGE GADTs, KindSignatures #-}
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE RebindableSyntax #-}

import qualified Prelude
import Prelude hiding (return, fail, (>>=), (>>))

Then a simple stack language:

data Op (i :: [*]) (j :: [*]) where
    IMM :: a -> Op i (a ': i)
    BINOP :: (a -> b -> c) -> Op (a ': b ': i) (c ': i)
    BRANCH :: Label i j -> Label i j -> Op (Bool ': i) j

and we won't bother with real Labels:

data Label (i :: [*]) (j :: [*]) where
    Label :: Prog i j -> Label i j

and Programs are just type-aligned lists of Ops:

data Prog (i :: [*]) (j :: [*]) where
    PNil :: Prog i i
    PCons :: Op i j -> Prog j k -> Prog i k

So in this setting, we can very easily make a compiler which is an indexed writer monad; that is, an indexed monad:

class IMonad (m :: idx -> idx -> * -> *) where
    ireturn :: a -> m i i a
    ibind :: m i j a -> (a -> m j k b) -> m i k b

-- For RebindableSyntax, so that we get that sweet 'do' sugar
return :: (IMonad m) => a -> m i i a
return = ireturn
(>>=) :: (IMonad m) => m i j a -> (a -> m j k b) -> m i k b
(>>=) = ibind
m >> n = m >>= const n
fail = error

that allows accumulating a(n indexed) monoid:

class IMonoid (m :: idx -> idx -> *) where
    imempty :: m i i
    imappend :: m i j -> m j k -> m i k

just like regular Writer:

newtype IWriter w (i :: [*]) (j :: [*]) (a :: *) = IWriter{ runIWriter :: (w i j, a) }

instance (IMonoid w) => IMonad (IWriter w) where
    ireturn x = IWriter (imempty, x)
    ibind m f = IWriter $ case runIWriter m of
        (w, x) -> case runIWriter (f x) of
            (w', y) -> (w `imappend` w', y)

itell :: w i j -> IWriter w i j ()
itell w = IWriter (w, ())

So we just apply this machinery to Programs:

instance IMonoid Prog where
    imempty = PNil
    imappend PNil prog' = prog'
    imappend (PCons op prog) prog' = PCons op $ imappend prog prog'

type Compiler = IWriter Prog

tellOp :: Op i j -> Compiler i j ()
tellOp op = itell $ PCons op PNil

label :: Compiler i j () -> Compiler k k (Label i j)
label m = case runIWriter m of
    (prog, ()) -> ireturn (Label prog)

and then we can try compiling a simple expression language:

data Expr a where
    Lit :: a -> Expr a
    And :: Expr Bool -> Expr Bool -> Expr Bool
    Plus :: Expr Int -> Expr Int -> Expr Int
    If :: Expr Bool -> Expr a -> Expr a -> Expr a

compile :: Expr a -> Compiler i (a ': i) ()
compile (Lit x) = tellOp $ IMM x
compile (And x y) = do
    compile x
    compile y
    tellOp $ BINOP (&&)
compile (Plus x y) = do
    compile x
    compile y
    tellOp $ BINOP (+)
compile (If b t e) = do
    labThen <- label $ compile t
    labElse <- label $ compile e
    compile b
    tellOp $ BRANCH labThen labElse

and if we omitted e.g. one of the arguments to BINOP, the typechecker will detect this:

compile (And x y) = do
    compile x
    tellOp $ BINOP (&&)

• Could not deduce: i ~ (Bool : i) from the context: a ~ Bool

Answer 3

Session types are an attempt to give type-level descriptions to networking protocols. The idea is that if a client sends a value, the server must be ready to receive it, and vice versa.

So here's a type (using TypeInType) describing sessions consisting of a sequence of values to send and values to receive.

infixr 5 :!, :?
data Session = Type :! Session
             | Type :? Session
             | E

a :! s means "send a value of type a, then continue with the protocol s". a :? s means "receive a value of type a, then continue with the protocol s".

So Session represents a (type-level) list of actions. Our monadic computations will work their way along this list, sending and receiving data as the type demands it. More concretely, a computation of type Chan s t a reduces the remaining work to be done to satisfy the protocol from s to t. I'll build Chan using the indexed free monad that I used in my answer to your other question.

class IFunctor f where
    imap :: (a -> b) -> f i j a -> f i j b
class IFunctor m => IMonad m where
    ireturn :: a -> m i i a
    (>>>=) :: m i j a -> (a -> m j k b) -> m i k b


data IFree f i j a where
    IReturn :: a -> IFree f i i a
    IFree :: f i j (IFree f j k a) -> IFree f i k a

instance IFunctor f => IFunctor (IFree f) where
    imap f (IReturn x) = IReturn (f x)
    imap f (IFree fx) = IFree (imap (imap f) fx)

instance IFunctor f => IMonad (IFree f) where
    ireturn = IReturn
    IReturn x >>>= f = f x
    IFree fx >>>= f = IFree (imap (>>>= f) fx)

Our base actions in the Chan monad will simply send and receive values.

data ChanF s t r where
    Send :: a -> r -> ChanF (a :! s) s r
    Recv :: (a -> r) -> ChanF (a :? s) s r

instance IFunctor ChanF where
    imap f (Send x r) = Send x (f r)
    imap f (Recv r) = Recv (fmap f r)

send :: a -> Chan (a :! s) s ()
send x = IFree (Send x (IReturn ()))

recv :: Chan (a :? s) s a
recv = IFree (Recv IReturn)

type Chan = IFree ChanF
type Chan' s = Chan s E  -- a "complete" Chan

send takes the current state of the session from a :! s to s, fulfilling the obligation to send an a. Likewise, recv transforms a session from a :? s to s.

Here's the fun part. When one end of the protocol sends a value, the other end must be ready to receive it, and vice versa. This leads to the idea of a session type's dual:

type family Dual s where
    Dual (a :! s) = a :? Dual s
    Dual (a :? s) = a :! Dual s
    Dual E = E

In a total language Dual (Dual s) = s would be provable, but alas Haskell is not total.

You can connect a pair of channels if their types are dual. (I guess you'd call this an in-memory simulation of connecting a client and a server.)

connect :: Chan' s a -> Chan' (Dual s) b -> (a, b)
connect (IReturn x) (IReturn y) = (x, y)
connect (IReturn _) (IFree y) = case y of {}
connect (IFree (Send x r)) (IFree (Recv f)) = connect r (f x)
connect (IFree (Recv f)) (IFree (Send y r)) = connect (f y) r

For example, here's a protocol for a server which tests whether a number is greater than 3. The server waits to receive an Int, sends back a Bool, and then ends the computation.

type MyProtocol = Int :? Bool :! E

server :: Chan' MyProtocol ()
server = do  -- using RebindableSyntax
    x <- recv
    send (x > 3)

client :: Chan' (Dual MyProtocol) Bool
client = do
    send 5
    recv

And to test it:

ghci> connect server client
((),True)

Session types are an area of active research. This particular implementation is fine for very simple protocols, but you can't describe protocols where the type of the data being sent over the wire depends on the state of the protocol. For that you need, surprise surprise, dependent types. See this talk by Brady for a quick demo of the state of the art of session types.