Working out the details of a type indexed free monad

Question

I\'ve been using a free monad to build a DSL. As part of the language, there is an input command, the goal is to reflect what types are expected by the input primit

Answer 1

If you're willing to sacrifice the implicit ordering and use explicit accessors instead, your Action '[Int, Int] could be implemented using ReaderT (HList '[Int, Int]). If you use an existing library like vinyl that provides lenses, you could write something like this:

-- Implemented with pseudo-vinyl
-- X and Y are Int fields, with accessors xField and yField
addTwo :: ReaderT (PlainRec '[X, Y]) Output ()
addTwo = do
  x <- view (rGet xField)
  y <- view (rGet yField)
  lift . output $ show (x + y) -- output :: String -> Output ()

Type safety is enforced by constraint propagation: rGet xField introduces a requirement that X be a member of the record.

For a simpler illustration without the type-level machinery, compare:

addTwo :: ReaderT (Int, Int) IO ()
addTwo = do
  x <- view _1
  y <- view _2
  lift . putStrLn $ show (x + y)

We lose the ordering property, which is significant loss, particularly if the ordering is meaningful, e.g. represents the order of user interaction.

Furthermore, we now have to use runReaderT (~ eval). We can't, say, interleave user input with output.

Answer 2

I have a working implementation of an indexed free monad on github from a few years back:

https://github.com/ekmett/indexed/blob/master/src/Indexed/Monad/Free.hs

It uses the form of indexed monad proposed by Conor McBride in Kleisli Arrows of Outrageous Fortune, and that can be adapted to provide a 2-index free monad in the style of Bob Atkey in the manner described in the paper as well.

Answer 3

EDIT: I have posted a more general alternative answer. I leave this answer here for now since it may be an useful example for constructing the target monad by hand.

My solution does what OP asked for (though it involves manual monad instance writing, so there's room for refinement certainly).

The effect-monad package (which OP mentioned) already contains an effect that handles reading from a HList. It's called ReadOnceReader. However, we also need a Writer effect for Output, and it seems to me that the library doesn't let us combine these two.

We can still take the idea of ReadOnceReader and manually write an AST for the desired language. The AST should be an indexed monad, of course. It would be neat if we could also do this through an indexed free monad or operational monad. I haven't had success with free monads thus far. I might update my answer after I looked at operational monads.

Preliminaries:

{-# LANGUAGE
    RebindableSyntax, DataKinds, ScopedTypeVariables,
    GADTs, TypeFamilies, TypeOperators,
    PolyKinds, StandaloneDeriving, DeriveFunctor #-}

import Prelude hiding (Monad(..))

data HList (xs :: [*]) where
  Nil  :: HList '[]
  (:>) :: x -> HList xs -> HList (x ': xs)
infixr 5 :>                     

type family (++) (xs :: [*]) (ys :: [*]) where
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

Indexed monads must provide a way to combine (Plus) indices, with identity (Unit). In short, indices should be monoids.

class IxMonad (m :: k -> * -> *) where
  type Unit m :: k
  type Plus m (i :: k) (j :: k) :: k
  return :: a -> m (Unit m) a
  (>>=)  :: m i a -> (a -> m j b) -> m (Plus m i j) b
  fail   :: m i a

The type of Input is of interest here: we prepend the input type to the resulting index of the next computation:

data Action i a where
  Return :: a -> Action '[] a
  Input  :: (x -> Action xs a) -> Action (x ': xs) a
  Output :: String -> Action i a -> Action i a
deriving instance Functor (Action i)

The IxMonad instance and the smart constructors are fully standard, and the eval function is also implemented straightforwardly.

instance IxMonad Action where
  type Unit Action = '[]
  type Plus Action i j = i ++ j
  return = Return
  Return a     >>= f = f a
  Input k      >>= f = Input ((>>= f) . k)
  Output s nxt >>= f = Output s (nxt >>= f)
  fail = undefined

input :: Action '[a] a
input = Input Return

output :: String -> Action '[] ()
output s = Output s (Return ())

eval :: Action xs a -> HList xs -> [String]
eval (Return a)     xs        = []
eval (Input k)      (x :> xs) = eval (k x) xs
eval (Output s nxt) xs        = s : eval nxt xs

Now everything works as desired:

concat' :: Action '[String, String] ()
concat' = do
  (x :: String) <- input
  (y :: String) <- input 
  output $ x ++ " " ++ y

main = print $ eval concat' ("a" :> "b" :> Nil)
-- prints ["a b"]

Answer 4

I have a new solution that is simple and quite generally applicable.

So far in the thread we've used monads indexed by a monoid, but here I rely on the other popular notion of an indexed monad, the one that has typestate transitions (Hoare logic-style):

    return :: a -> m i i a
    (>>=) :: m i j a -> (a -> m j k b) -> m i k b

I believe the two approaches are equivalent (at least in theory), since we get the Hoare monad by indexing with the endomorphism monoid, and we can also go in the opposite direction by CPS encoding the monoidal appends in the state transitions. In practice, Haskell's type-level and kind-level language is rather weak, so moving back-and-forth between the two representations is not an option.

There is a problem though with the above type for >>=: it implies that we must compute the typestate in a top-down order, i. e. it forces the following definition for IxFree:

data IxFree f i j a where
  Pure :: a -> IxFree f i i a
  Free :: f i j (IxFree f j k a) -> IxFree f i k a

So, if we have a Free exp expression, then we first transition from i to j following the constructor of exp, and then get from j to k by checking the subexperssions of exp. This means that if we try to accumulate the input types in a list, we end up with a reversed list:

-- compute transitions top-down
test = do
  (x :: Int) <- input       -- prepend Int to typestate
  (y :: String) <- input    -- prepend String to typestate
  return ()                 -- do nothing         

If we instead appended the types to the end of the list, the order would be right. But making that work in Haskell (especially making eval work) would require a gruelling amount of proof-writing, if it's even possible.

Let's compute the typestate bottom-up instead. It makes all kinds of computations where we build up some data structure depending on the syntax tree much more natural, and in particular it makes our job very easy here.

{-# LANGUAGE
    RebindableSyntax, DataKinds,
    GADTs, TypeFamilies, TypeOperators,
    PolyKinds, StandaloneDeriving, DeriveFunctor #-}

import Prelude hiding (Monad(..))

class IxFunctor (f :: ix -> ix -> * -> *) where
    imap :: (a -> b) -> f i j a -> f i j b

class IxFunctor m => IxMonad (m :: ix -> ix -> * -> *) where
    return :: a -> m i i a
    (>>=) :: m j k a -> (a -> m i j b) -> m i k b -- note the change of index orders

    (>>) :: m j k a -> m i j b -> m i k b -- here too
    a >> b = a >>= const b

    fail :: String -> m i j a
    fail = error

data IxFree f i j a where
  Pure :: a -> IxFree f i i a
  Free :: f j k (IxFree f i j a) -> IxFree f i k a -- compute bottom-up

instance IxFunctor f => Functor (IxFree f i j) where
  fmap f (Pure a)  = Pure (f a)
  fmap f (Free fa) = Free (imap (fmap f) fa)

instance IxFunctor f => IxFunctor (IxFree f) where
  imap = fmap

instance IxFunctor f => IxMonad (IxFree f) where
  return = Pure
  Pure a  >>= f = f a
  Free fa >>= f = Free (imap (>>= f) fa)

liftf :: IxFunctor f => f i j a -> IxFree f i j a
liftf = Free . imap Pure

Now implementing Action becomes simple.

data ActionF i j next where
  Input  :: (a -> next) -> ActionF i (a ': i) next
  Output :: String -> next -> ActionF i i next

deriving instance Functor (ActionF i j)                                      
instance IxFunctor ActionF where
  imap = fmap

type family (++) xs ys where -- I use (++) here only for the type synonyms
  '[] ++ ys = ys
  (x ': xs) ++ ys = x ': (xs ++ ys)

type Action' xs rest = IxFree ActionF rest (xs ++ rest)
type Action xs a = forall rest. IxFree ActionF rest (xs ++ rest) a  

input :: Action '[a] a
input = liftf (Input id)

output :: String -> Action '[] ()
output s = liftf (Output s ())

data HList i where
  HNil :: HList '[]
  (:::) :: h -> HList t -> HList (h ': t)
infixr 5 :::

eval :: Action' xs r a -> HList xs -> [String]
eval (Pure a)              xs         = []
eval (Free (Input k))      (x ::: xs) = eval (k x) xs
eval (Free (Output s nxt)) xs         = s : eval nxt xs

addTwice :: Action [Int, Int] ()
addTwice = do
  x <- input
  y <- input
  output (show $ x + y)

To make things less confusing for users, I introduced type synonyms with friendlier index schemes: Action' xs rest a means that the action reads from xs and may be followed by actions containing rest reads. Action is a type synonym equivalent to the one appearing in the thread question.

We can implement a variety of DSL-s with this approach. The reversed typing order gives it a bit of a spin, but we can do the usual indexed monads all the same. Here's the indexed state monad, for example:

data IxStateF i j next where
  Put :: j -> next -> IxStateF j i next
  Get :: (i -> next) -> IxStateF i i next

deriving instance Functor (IxStateF i j)
instance IxFunctor IxStateF where imap = fmap

put s = liftf (Put s ())
get   = liftf (Get id)

type IxState i j = IxFree IxStateF j i

evalState :: IxState i o a -> i -> (a, o)
evalState (Pure a)         i = (a, i)
evalState (Free (Get k))   i = evalState (k i) i
evalState (Free (Put s k)) i = evalState k s

test :: IxState Int String ()
test = do
  n <- get
  put (show $ n * 100)

Now, I believe this approach is a fair bit more practical than indexing with monoids, because Haskell doesn't have kind classes or first-class type level functions that would make the monoid approach palatable. It would be nice to have a VerifiedMonoid class, like in Idris or Agda, which includes correctness proofs besides the usual methods. That way we could write a FreeIx that is generic in the choice of the index monoid, and not restricted to lifted lists or something else.

Answer 5

Shortly about indexed monads: They are monads indexed by monoids. For comparison default monad:

class Monad m where
  return :: a -> m a
  bind :: m a -> (a -> m b) -> m b
  -- or `bind` alternatives:
  fmap :: (a -> b) -> m a -> m b
  join :: m (m a) -> m a

A monoid is a type equiped with mempty - identity element, and (<>) :: a -> a -> a binary associative operation. Raised to type-level we could have Unit type, and Plus associative binary type operation. Note, a list is a free monoid on value level, and HList is on a type level.

Now we can define indexed monoid class:

class IxMonad m where
  type Unit
  type Plus i j

  return :: a -> m Unit a
  bind :: m i a -> (a -> m j b) -> m (Plus i j) b
  --
  fmap :: (a -> b) -> m i a -> m i b
  join :: m i (m j a) -> m (Plus i j) a

You can state monad laws for indexed version. You'll notice that for indexes to align, they must obey monoid laws.

---

With free monad you want equip a Functor with return and join operations. With slightly altererd your definition works:

data FreeIx f i a where
  Return :: a -> FreeIx f '[] a -- monoid laws imply we should have `[] as index here!
  Free :: f (FreeIx f k a) -> FreeIx f k a

bind :: Functor f => FreeIx f i a -> (a -> FreeIx f j b) -> FreeIx f (Append i j) b
bind (Return a) f = f a
bind (Free x) f   = Free (fmap (flip bind f) x)

---

I have to admit, I'm not 100% sure how Free constructor indexes are justified, but they seem to work. If we consider the function wrap :: f (m a) -> m a of MonadFree class with a law:

wrap (fmap f x) ≡ wrap (fmap return x) >>= f

and a comment about Free in free package

In practice, you can just view a Free f a as many layers of f wrapped around values of type a, where (>>=) performs substitution and grafts new layers of f in for each of the free variables.

then the idea is that wrapping values doesn't affect the index.

---

Yet, you want to lift any f value to an arbitrary indexed monadic value. This is a very reasonable requirement. But the only valid definition forces lifted value to have '[] - Unit or mempty index:

liftF :: Functor f => f a -> FreeIx f '[] a
liftF = Free . fmap Return

If you try to change Return definition to :: a -> FreeIx f k a (k, not [] -- pure value could have an arbitrary index), then bind definition won't type check.

---

I'm not sure if you can make the free indexed monad work with small corrections only. One idea is to lift an arbitrary monad into an indexed monad:

data FreeIx m i a where
  FreeIx :: m a -> FreeIx m k a

liftF :: Proxy i -> f a -> FreeIx f i a
liftF _ = FreeIx

returnIx :: Monad m => a -> FreeIx m i a
returnIx = FreeIx . return

bind :: Monad m => FreeIx m i a -> (a -> FreeIx m j b) -> FreeIx m (Append i j) b
bind (FreeIx x) f = FreeIx $ x >>= (\x' -> case f x' of
                                             FreeIx y -> y)

This approach feels a bit like cheating, as we could always re-index the value.

---

Another approach is to remind Functor it's a indexed functor, or start right away with indexed functor as in Cirdec's answer.

Answer 6

I have found a satisfactory solution to this problem. Here's a sneak peek at the ultimate result:

addTwo = do
  (x :: Int) <- input
  (y :: Int) <- input 
  output $ show (x + y)

eval (1 ::: 2 ::: HNil) addTwo = ["3"]

Accomplishing this requires a large number of steps. First, we need to observe that the ActionF data type is itself indexed. We will adapt FreeIx to build an indexed monad using the free monoid, lists. The Free constructor for FreeIx will need to capture a witness to the finiteness of one of its two indexes for use in proofs. We will use a system due to András Kovács for writing proofs about appending type level lists to make proofs of both associativity and the right identity. We will describe indexed monads in the same manner as Oleg Grenrus. We will use the RebindbableSyntax extension to write expressions for an IxMonad using the ordinary do notation.

Prologue

In addition to all of the extensions your example already requires and RebindbableSyntax which was mentioned above we will also need UndecidableInstances for the trivial purpose of reusing a type family definition.

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RebindableSyntax #-}

We will be using the :~: GADT from Data.Type.Equality to manipulate type equality.

import Data.Type.Equality
import Data.Proxy

Because we will be rebinding the Monad syntax, we'll hide all of Monad from the Prelude import. The RebindableSyntax extension uses for do notation whatever functions >>=, >>, and fail are in scope.

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

We also have a few bits of new general-purpose library code. I have given the HList an infix constructor, :::.

data HList i where
  HNil :: HList '[]
  (:::) :: h -> HList t -> HList (h ': t)

infixr 5 :::

I have renamed the Append type family ++ to mirror the ++ operator on lists.

type family (++) (a :: [k]) (b :: [k]) :: [k] where
  '[]      ++ l  = l
  (e ': l) ++ l' = e ': l ++ l'

It's useful to talk about constraints of the form forall i. Functor (f i). These don't exist in Haskell outside GADTs that capture constraints like the Dict GADT in constraints. For our purposes, it will be sufficient to define a version of Functor with an extra ignored argument.

class Functor1 (f :: k -> * -> *) where
    fmap1 :: (a -> b) -> f i a -> f i b

Indexed ActionF

The ActionF Functor was missing something, it had no way to capture type level information about the requirements of the methods. We'll add an additional index type i to capture this. Input requires a single type, '[a], while Output requires no types, '[]. We are going to call this new type parameter the index of the functor.

data ActionF i next where
   Input :: (a -> next) ->  ActionF '[a] next
   Output :: String -> next -> ActionF '[] next 

We'll write Functor and Functor1 instances for ActionF.

instance Functor (ActionF i) where
  fmap f (Input c) = Input (fmap f c)
  fmap f (Output s n) = Output s (f n)

instance Functor1 ActionF where
  fmap1 f = fmap f

FreeIx Reconstructed

We are going to make two changes to FreeIx. We will change how the indexes are constructed. The Free constructor will refer to the index from the underlying functor, and produce a FreeIx with an index that's the free monoidal sum (++) of the index from the underlying functor and the index from the wrapped FreeIx. We will also require that Free captures a witness to a proof that the index of the underlying functor is finite.

data FreeIx f (i :: [k]) a where
  Return :: a -> FreeIx f '[] a
  Free :: (WitnessList i) => f i (FreeIx f j a) -> FreeIx f (i ++ j) a

We can define Functor and Functor1 instances for FreeIx.

instance (Functor1 f) => Functor (FreeIx f i) where
  fmap f (Return a) = Return (f a)
  fmap f (Free x) = Free (fmap1 (fmap f) x)

instance (Functor1 f) => Functor1 (FreeIx f) where
  fmap1 f = fmap f

If we want to use FreeIx with an ordinary, unindexed functor, we can lift those values to an unconstrained indexed functor, IxIdentityT. This isn't needed for this answer.

data IxIdentityT f i a = IxIdentityT {runIxIdentityT :: f a}

instance Functor f => Functor (IxIdentityT f i) where
    fmap f = IxIdentityT . fmap f . runIxIdentityT

instance Functor f => Functor1 (IxIdentityT f) where
    fmap1 f = fmap f

Proofs

We will need to prove two properties about appending type level lists. In order to write liftF we will need to prove the right identity xs ++ '[] ~ xs. We'll call this proof appRightId for append right identity. In order to write bind we will need to prove associativity xs ++ (yz ++ zs) ~ (xs ++ ys) ++ zs, which we will call appAssoc.

The proofs are written in terms of a successor list which is essentially a list of proxies, one for each type type SList xs ~ HFMap Proxy (HList xs).

data SList (i :: [k]) where
  SNil :: SList '[]
  SSucc :: SList t -> SList (h ': t)

The following proof of associativity along with the method of writing this proof are due to András Kovács. By only using SList for the type list of xs we deconstruct and using Proxys for the other type lists, we can delay (possibly indefinitely) needing WitnessList instances for ys and zs.

appAssoc ::
  SList xs -> Proxy ys -> Proxy zs ->
  (xs ++ (ys ++ zs)) :~: ((xs ++ ys) ++ zs)
appAssoc SNil ys zs = Refl
appAssoc (SSucc xs) ys zs =
  case appAssoc xs ys zs of Refl -> Refl

Refl, the constructor for :~:, can only be constructed when the compiler is in possession of a proof that the two types are equal. Pattern matching on Refl introduces the proof of type equality into the current scope.

We can prove the right identity in a similar fashion

appRightId :: SList xs -> xs :~: (xs ++ '[])
appRightId SNil = Refl
appRightId (SSucc xs) = case appRightId xs of Refl -> Refl

To use these proofs we construct witness lists for the the class of finite type lists.

class WitnessList (xs :: [k]) where
  witness :: SList xs

instance WitnessList '[] where
  witness = SNil

instance WitnessList xs => WitnessList (x ': xs) where
  witness = SSucc witness

Lifting

Equipped with appRightId we can define lifting values from the underlying functor into FreeIx.

liftF :: forall f i a . (WitnessList i, Functor1 f) => f i a -> FreeIx f i a
liftF = case appRightId (witness :: SList i) of Refl -> Free . fmap1 Return

The explicit forall is for ScopedTypeVariables. The witness to the finiteness of the index, WitnessList i, is required by both the Free constructor and appRightId. The proof of appRightId is used to convince the compiler that the FreeIx f (i ++ '[]) a constructed is of the same type as FreeIx f i a. That '[] came from the Return that was wrapped in the underlying functor.

Our two commands, input and output, are written in terms of liftF.

type Action i a = FreeIx ActionF i a

input :: Action '[a] a
input = liftF (Input id)

output :: String -> Action '[] ()
output s = liftF (Output s ())

IxMonad and Binding

To use RebindableSyntax we'll define an IxMonad class with the same function names (>>=), (>>), and fail as Monad but different types. This class is described in Oleg Grenrus's answer.

class Functor1 m => IxMonad (m :: k -> * -> *) where
    type Unit :: k
    type Plus (i :: k) (j :: k) :: k

    return :: a -> m Unit a
    (>>=) :: m i a -> (a -> m j b) -> m (Plus i j) b

    (>>) :: m i a -> m j b -> m (Plus i j) b
    a >> b = a >>= const b

    fail :: String -> m i a
    fail s = error s

Implementing bind for FreeIx requires the proof of associativity, appAssoc. The only WitnessList instance in scope, WitnessList i, is the one captured by the deconstructed Free constructor. Once again, the explicit forall is for ScopedTypeVariables.

bind :: forall f i j a b. (Functor1 f) => FreeIx f i a -> (a -> FreeIx f j b) -> FreeIx f (i ++ j) b
bind (Return a) f = f a
bind (Free (x :: f i1 (FreeIx f j1 a))) f =
    case appAssoc (witness :: SList i1) (Proxy :: Proxy j1) (Proxy :: Proxy j)
    of Refl -> Free (fmap1 (`bind` f) x)

bind is the only interesting part of the IxMonad instance for FreeIx.

instance (Functor1 f) => IxMonad (FreeIx f) where
    type Unit = '[]
    type Plus i j = i ++ j

    return = Return
    (>>=) = bind

We're done

All of the hard part is done. We can write a simple interpreter for Action xs () in the most straight forward fashion. The only trick required is to avoid pattern matching on the HList constructor ::: until after the type list i is known to be non-empty because we already matched on Input.

eval :: HList i -> Action i () -> [String]
eval inputs action = 
    case action of 
        Return () -> []
        Free (Input f) -> 
            case inputs of
                (x ::: xs) -> eval xs (f x)
        Free (Output s next) -> s : eval inputs next

If you are curious about the inferred type of addTwo

addTwo = do
  (x :: Int) <- input
  (y :: Int) <- input 
  output $ show (x + y)

it is

> :t addTwo
addTwo :: FreeIx ActionF '[Int, Int] ()