As of yesterday, I have typeclass resolution working. The algorithm to desugar constraints into dictionaries hasn't been discussed much. Since it's rather involved, and quite interesting, I thought it might make a good topic for a blog post.

Our journey begins having just implemented Algorithm W aka Hindley-Milner. This is pretty well described in the literature, and there exist several implementations of it in Haskell, so we will not dally here. Algorithm W cashes out in a function of the type:

`infer :: SymTable VName Type -> Exp VName -> TI Type`

where `SymTable VName`

is a mapping from identifiers in scope to their types, `Exp VName`

is an expression we want to infer, and `TI`

is our type-inference monad. As a monad, `TI`

gives us the ability to generate fresh type variables, and to unify types as we go. `Type`

represents an unqualified type, which is to say it can be used to describe the types `a`

, and `Int`

, but not `Eq a => a`

. We will be implementing qualified types in this blog post.

`infer`

is implemented as a catamorphism, which generates a fresh type variable for every node in the expression tree, looks up free variables in the `SymTable`

and attempts to unify as it goes.

The most obvious thing we need to do in order to introduce constraints to our typechecker is to be able to represent them, so we two types:

```
infixr 0 :=>
data Qual t = (:=>)
{ qualPreds :: [Pred]
, unqualType :: t
} deriving (Eq, Ord, Functor, Traversable, Foldable)
data Pred = IsInst
{ predCName :: TName
, predInst :: Type
} deriving (Eq, Ord)
```

Cool. A `Qual Type`

is now a qualified type, and we can represent `Eq a => a`

via `[IsInst "Eq" "a"] :=> "a"`

(assuming `OverloadedStrings`

is turned on.) With this out of the way, we'll update the type of `infer`

so its symbol table is over `Qual Types`

, and make it return a list of `Pred`

s:

`infer :: SymTable VName (Qual Type) -> Exp VName -> TI ([Pred], Type)`

We update the algebra behind our `infer`

catamorphism so that adds any `Pred`

s necessary when instantiating types:

```
infer sym (V a) =
case lookupSym a sym of
Nothing -> throwE $ "unbound variable: '" <> show a <> "'"
Just sigma -> do
(ps :=> t) <- instantiate a sigma
pure (ps, t)
```

and can patch any other cases which might generate `Pred`

s. At the end of our cata, we'll have a big list of constraints necessary for the expression to typecheck.

As a first step, we'll just write the type-checking part necessary to implement this feature. Which is to say, we'll need a system for discharging constraints at the type-level, without necessarily doing any work towards code generation.

Without the discharging step, for example, our algorithm will typecheck `(==) (1 :: Int)`

as `Eq Int => Int -> Bool`

, rather than `Int -> Bool`

(since it knows `Eq Int`

.)

Discharging is a pretty easy algorithm. For each `Pred`

, see if it matches the instance head of any instances you have in scope; if so, recursively discharge all of the instance's context. If you are unable to find any matching instances, just keep the `Pred`

. For example, given the instances:

```
instance Eq Int
instance (Eq a, Eq b) => Eq (a, b)
```

and a `IsInst "Eq" ("Int", "c")`

, our discharge algorithm will look like this:

```
discharging: Eq (Int, c)
try: Eq Int --> does not match
try: Eq (a, b) --> matches
remove `Eq (Int, c)` pred
match types:
a ~ c
b ~ Int
discharge: Eq Int
discharge: Eq c
discharging: Eq Int
try: Eq Int --> matches
remove `Eq Int` pred
discharging: Eq c
try: Eq Int --> does not match
try: Eq (a, b) --> does not match
keep `Eq c` pred
```

We can implement this in Haskell as:

```
match :: Pred -> Pred -> TI (Maybe Subst)
getInsts :: ClassEnv -> [Qual Pred]
discharge :: ClassEnv -> Pred -> TI (Subst, [Pred])
discharge cenv p = do
-- find matching instances and return their contexts
matchingInstances <-
for (getInsts cenv) $ \(qs :=> t) -> do
-- the alternative here is to prevent emitting kind
-- errors if we compare this 'Pred' against a
-- differently-kinded instance.
res <- (fmap (qs,) <$> match t p) <|> pure Nothing
pure $ First res
case getFirst $ mconcat matchingInstances of
Just (qs, subst) ->
-- match types in context
let qs' = sub subst qs
-- discharge context
fmap mconcat $ traverse (discharge cenv) qs'
Nothing ->
-- unable to discharge
pure (mempty, pure p)
```

Great! This works as expected, and if we want to only write a type-checker, this is sufficient. However, we don't want to only write a type-checker, we also want to generate code capable of using these instances too!

We can start by walking through the transformation in Haskell, and then generalizing from there into an actual algorithm. Starting from a class definition:

```
class Functor f where
fmap :: (a -> b) -> f a -> f b
```

we will generate a dictionary type for this class:

```
data @Functor f = @Functor
{ @fmap :: (a -> b) -> f a -> f b
}
```

(I'm using the `@`

signs here because these things are essentially type applications. That being said, there will be no type applications in this post, so the `@`

should always be understood to be machinery generated by the compiler for dictionary support.)

Such a definition will give us the following terms:

```
@Functor :: ((a -> b) -> f a -> f b) -> @Functor f
@fmap :: @Functor f -> (a -> b) -> f a -> f b
```

Notice that `@fmap`

is just `fmap`

but with an explicit dictionary (`@Functor f`

) being passed in place of the `Functor f`

constraint.

From here, in order to actually construct one of these dictionaries, we can simply inline an instances method:

```
instance Functor Maybe where
fmap = \f m -> case m of { Just x -> Just (f x); Nothing -> Nothing }
-- becomes
@Functor@Maybe :: @Functor Maybe
@Functor@Maybe =
@Functor
{ @fmap = \f m -> case m of { Just x -> Just (f x); Nothing -> Nothing }
}
```

Now we need to look at how these dictionaries actually get used. It's clear that every `fmap`

in our expression tree should be replaced with `@fmap d`

for some `d`

. If the type of `d`

is monomorphic, we can simply substitute the dictionary we have:

```
x :: Maybe Int
x = fmap (+5) (Just 10)
-- becomes
x :: Maybe Int
x = @fmap @Functor@Maybe (+5) (Just 10)
```

but what happens if the type `f`

is polymorphic? There's no dictionary we can reference statically, so we'll need to take it as a parameter:

```
y :: Functor f => f Int -> f Int
y = \z -> fmap (+5) z
-- becomes
y :: @Functor f -> f Int -> f Int
y = \d -> \z -> @fmap d (+5) z
```

A reasonable question is when should we insert these lambdas to bind the dictionaries? This stumped me for a while, but the answer is whenever you get to a binding group; which is to say whenever your expression is bound by a `let`

, or whenever you finish processing a top-level definition.

One potential gotcha is what should happen in the case of instances with their own contexts? For example, `instance (Eq a, Eq b) => Eq (a, b)`

? Well, the same rules apply; since `a`

and `b`

are polymorphic constraints, we'll need to parameterize our `@Eq@(,)`

dictionary by the dictionaries witnessing `Eq a`

and `Eq b`

:

```
instance (Eq a, Eq b) => Eq (a, b) where
(==) = \ab1 ab2 -> (==) (fst ab1) (fst ab2)
&& (==) (snd ab1) (snd ab2)
-- becomes
@Eq@(,) :: @Eq a -> @Eq b -> @Eq (a, b)
@Eq@(,) = \d1 -> \d2 ->
@Eq
{ (@==) = \ab1 ab2 -> (@==) d1 (fst ab1) (fst ab2)
&& (@==) d2 (snd ab1) (snd ab2)
}
```

Super-class constraints behave similarly.

So with all of the theory under our belts, how do we actually go about implementing this? The path forward isn't as straight-forward as we might like; while we're type-checking we need to desugar terms with constraints on them, but the result of that desugaring depends on the eventual type these terms receive.

For example, if we see `(==)`

in our expression tree, we want to replace it with `(@==) d`

where `d`

might be `@Eq@Int`

, or it might be `@Eq@(,) d1 d2`

, or it might just stay as `d`

! And the only way we'll know what's what is *after* we've performed the dischargement of our constraints.

As usual, the solution is to slap more monads into the mix:

```
infer
:: SymTable VName (Qual Type)
-> Exp VName
-> TI ( [Pred]
, Type
, Reader (Pred -> Exp VName)
(Exp VName)
)
```

Our `infer`

catamorphism now returns an additional `Reader (Pred -> Exp VName) (Exp VName)`

, which is to say an expression that has access to which expressions it should substitute for each of its `Pred`

s. We will use this mapping to assign dictionaries to `Pred`

s, allowing us to fill in the dictionary terms once we've figured them out.

We're in the home stretch; now all we need to do is to have `discharge`

build that map from `Pred`

s into their dictionaries and we're good to go.

```
getDictTerm :: Pred -> Exp VName
getDictTypeForPred :: Pred -> Type
-- DSL-level function application
(:@) :: Exp VName -> Exp VName -> Exp VName
discharge
:: ClassEnv
-> Pred
-> TI ( Subst
, [Pred]
, Map Pred (Exp VName)
, [Assump Type]
, [Exp VName]
)
discharge cenv p = do
matchingInstances <-
for (getInsts cenv) $ \(qs :=> t) -> do
res <- (fmap (qs, t, ) <$> match t p) <|> pure Nothing
pure $ First res
case getFirst $ mconcat matchingInstances of
Just (qs, t, subst) ->
-- discharge all constraints on this instance
(subst', qs', mapPreds, assumps, subDicts)
<- fmap mconcat
. traverse (discharge cenv)
$ sub subst qs
let dictTerm = getDictTerm t
myDict = foldl (:@) dictTerm subDicts
pure ( subst'
, qs'
, mapPreds <> M.singleton p myDict
, assumps
-- this is just in a list so we can use 'mconcat' to
-- collapse our traversal
, [myDict]
)
Nothing ->
-- unable to discharge, so assume the existence of a new
-- variable with the correct type
param <- newVName "d"
pure ( mempty
, [p]
, M.singleton p param
, [MkAssump param $ getDictTypeForPred p]
, [param]
)
```

The logic of `discharge`

is largely the same, except we have a little more logic being driven by its new type. We now, in addition to our previous substitution and new predicates, also return a map expanding dictionaries, a list of `Assump`

s (more on this in a second), and the resulting dictionary witnessing this discharged `Pred`

.

If we were successful in finding a matching instance, we discharge each of its constraints, and fold the resulting dictionaries into ours. The more interesting logic is what happens if we are unable to discharge a constraint. In that case, we create a new variable of the necessary type, give that as our resulting dictionary, and emit it as an `Assump`

. `Assump`

s are used to denote the creation of a new variable in scope (they are also used for binding pattern matches).

The result of our new `discharge`

function is that we have a map from every `Pred`

we saw to the resulting dictionary for that instance, along with a list of generated variables. We can build our final expression tree via running the `Reader (Pred -> Exp VName)`

by looking up the `Pred`

s in our dictionary map. Finally, for every assumption we were left with, we fold our resulting term in a lambda which binds that assumption.

Very cool! If you're interested in more of the nitty-gritty details behind compiling Haskell98, feel free to SMASH THAT STAR BUTTON on Github.

]]>One of the biggest concerns over the HKD technique was that it breaks automated deriving of instances. This is not entirely true, it just requires turning on `{-# LANGUAGE StandaloneDeriving #-}`

and then using one of two approaches.

The simplest method is that we can simply derive all of our instances only for the types we expect to use:

```
deriving instance Eq (Person' Identity)
deriving instance Eq (Person' Maybe)
deriving instance Ord (Person' Identity)
deriving instance Ord (Person' Maybe)
```

Admittedly it's kind of a shit solution, but technically it does work.

An alternative approach is to automatically lift these instances from `f a`

over the `HKD f a`

type family. The construction is a little more involved than I want to get into today, but thankfully it's available as library code from the spiffy `one-liner`

package.

After adding `one-liner`

as a dependency, we can lift our instances over a polymorphic `f`

using the `Constraints`

type-synonym:

`deriving instance (Constraints (Person' f) Eq) => Eq (Person' f)`

Easy!

The other big concern was over whether we pay performance costs for getting so many cool things for free.

For the most part, if you mark all of your generic type-class methods as `INLINE`

and turn on `-O2`

, most of the time you're not going to pay any runtime cost for using the HKD technique.

Don't believe me? I can prove it, at least for our free lenses.

Let's fire up the `inspection-testing`

package, which allows us to write core-level equalities that we'd like the compiler to prove for us. The equality we want to show is that the core generated for using our free lenses is exactly what would be generated by using hand-written lenses.

We can do this by adding some front-matter to our module:

```
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}
import Test.Inspection
```

This installs the `inspection-testing`

compiler plugin, which is responsible for doing the work for us. Next, we'll define our lenses:

```
freeName :: Lens' (Person' Identity) String
Person (LensFor freeName) _ = getLenses
handName :: Lens' (Person' Identity) String
handName a2fb s = a2fb (pName s) <&> \b -> s { pName = b }
```

and finally, we can write the equalities we'd like GHC to prove for us. This is done in two steps -- writing top-level left- and right- handed sides of the equality, and then writing a TemplateHaskell splice to generate the proof.

```
viewLhs, viewRhs :: Person' Identity -> String
viewLhs = view freeName
viewRhs = view handName
inspect $ 'viewLhs === 'viewRhs
```

Compiling this dumps some new information into our terminal:

```
src/Main.hs:34:1: viewLhs === viewRhs passed.
inspection testing successful
expected successes: 1
```

We can write an analogy equality to ensure that the generated setter code is equivalent:

```
setLhs, setRhs :: String -> Person' Identity -> Person' Identity
setLhs y = freeName .~ y
setRhs y = handName .~ y
inspect $ 'setLhs === 'setRhs
```

And upon compiling this:

```
src/Main.hs:34:1: viewLhs === viewRhs passed.
src/Main.hs:35:1: setLhs === setRhs passed.
inspection testing successful
expected successes: 2
```

Cool! Just to satisfy your curiosity, the actual lenses themselves aren't equivalent:

`inspect $ 'freeName === 'handName`

results in a big core dump showing that `freeName`

is a gross disgusting chain of `fmap`

s and that `handName`

is pretty and elegant. And the module fails to compile, which is neat -- it means we can write these proofs inline and the compiler will keep us honest if we ever break them.

But what's cool here is that even though our lenses do *not* result in equivalent code, actually using them does -- which means that under most circumstances, we won't be paying to use them.

`* -> *`

, and subsequently wrapping each of its fields by this parameter. The example we used previously was transforming this type:
```
data Person = Person
{ pName :: String
, pAge :: Int
} deriving (Generic)
```

into its HKD representation:

```
data Person' f = Person
{ pName :: HKD f String
, pAge :: HKD f Int
} deriving (Generic)
```

Recall that `HKD`

is a type family given by

```
type family HKD f a where
HKD Identity a = a
HKD f a = f a
```

which is responsible for stripping out an `Identity`

wrapper. This means we can recreate our original `Person`

type via `type Person = Person' Identity`

, and use it in all the same places we used to be able to.

Our previous exploration of the topic unearthed some rather trivial applications of this approach; we generated a function `validate :: f Maybe -> Maybe (f Identity)`

which can roughly be described as a "type-level `sequence`

." In fact, in the comments, Syrak pointed out we can implement this function in a less-round-about way via `gtraverse id`

.

So, how about we do something a little more interesting today? Let's generate lenses for arbitrary product types.

In my opinion, one of the biggest advantages of the HKD approach is it answers the question "where can we put this stuff we've generated?" Generating lenses generically is pretty trivial (once you have wrapped your head around the mind-boggling types), but the harder part is where to put it. The `lens`

package uses TemplateHaskell to generate new top-level bindings so it has somewhere to put the lenses. But we have HKD.

Recall, our `Person'`

type:

```
data Person' f = Person
{ pName :: HKD f String
, pAge :: HKD f Int
} deriving (Generic)
```

By substituting `f ~ Lens' (Person' Identity)`

, we'll have `pName :: Lens' (Person' Identity) String`

, which is exactly the type we need. All of a sudden it looks like we have an answer to "where should we put it": inside our original structure itself. If we can generate a record of type `Person' (Lens' (Person' Identity)`

, destructuring such a thing will give us the lenses we want, allowing us to name them when we do the destructuring. Cool!

Unfortunately, we're unable to partially apply type-synonyms, so we'll need to introduce a new type constructor that we *can* partially apply. Enter `LensesFor`

:

```
data LensFor s a = LensFor
{ getLensFor :: Lens' s a
}
```

The next step is to *think really hard* about what our lens-providing type-class should look like. At the risk of sounding like a scratched CD in a walkman, I consider the design of the typeclass to be by far the hardest part of this approach. So we'll work through the derivation together:

I always begin with my "template" generic-deriving class:

```
class GLensesFor i o where
glenses :: i p -> o p
```

where `p`

is a mysterious existentialized type parameter "reserved for future use" by the `GHC.Generics`

interface. Recall that `i`

is the incoming type for the transformation (*not* the original `Person'`

type), and `o`

is correspondingly the output type of the transformation.

Since lenses don't depend on a particular "input" record -- they should be able to be generated *ex nihilo* -- we can drop the `i p`

parameter from `glenses`

. Furthermore, since eventually our lenses are going to depend on our "original" type (the `Person'`

in our desired `LensesFor (Person' Identity)`

), we'll need another parameter in our typeclass to track that. Let's call it `z`

.

```
class GLensesFor z i o where
glenses :: o p
```

As far as methods go, `glenses`

is pretty unsatisfactory right now; it leaves most of its type parameters ambiguous. No good. We can resolve this issue by realizing that we're going to need to actually provide lenses at the end of the day, and because `GHC.Generics`

doesn't give us any such functionality, we'll need to write it ourselves. Which implies we're going to need to do structural induction as we traverse our generic `Rep`

resentation.

The trick here is that in order to provide a lens, we're going to need to have a lens to give. So we'll add a `Lens'`

to our `glenses`

signature -- but what type should it have? At the end of the day, we want to provide a `Lens' (z Identity) a`

where `a`

is the type of the field we're trying to get. Since we always want a lens starting from `z Identity`

, that pins down one side of our lens parameter.

```
class GLensesFor z i o where
glenses :: Lens' (z Identity) _ -> o p
```

We still have the notion of an `i`

nput to our `glenses`

, which we want to transform into our `o`

utput. And that's what tears it; if we have a lens from our original type where we currently are in our Generic traversal, we can transform that into a Generic structure which contains the lenses we want.

```
class GLensesFor z i o where
glenses :: Lens' (z Identity) (i p) -> o p
```

Don't worry if you're not entirely sure about the reasoning here; I wasn't either until I worked through the actual implementation. It took a few iterations to get right. Like I said, figuring out what this method should look like is by far the hardest part. Hopefully going through the rest of the exercise will help convince us that we got our interface correct.

With our typeclass pinned down, we're ready to begin our implementation. We start, as always, with the base case, which here is "what should happen if we have a `K1`

type?" Recall a `K1`

corresponds to the end of our generic structural induction, which is to say, this is a type that isn't ours. It's the `HKD f String`

in `pName :: HKD f String`

from our example.

So, if we have an `a`

wrapped in a `K1`

, we want to instead produce a `LensFor (z Identity) a`

wrapped in the same.

```
instance GLenses z (K1 _x a)
(K1 _x (LensFor (z Identity) a)) where
glenses l = K1 -- [3]
$ LensFor -- [2]
$ \f -> l $ fmap K1 . f . unK1 -- [1]
{-# INLINE glenses #-}
```

Egads there's a lot going on here. Let's work through it together. In [1], we transform the lens we were given (`l`

) so that it will burrow through a `K1`

constructor -- essentially turning it from a `Lens' (z Identity) (K1 _x a)`

into a `Lens' (z Identity) a`

. At [2], we wrap our generated lens in the `LensFor`

constructor, and then in [3] we wrap our generated lens back in the `GHC.Generics`

machinery so we can transform it back into our HKD representation later.

And now for our induction. The general idea here is that we're going to need to transform the lens we got into a new lens that focuses down through our generic structure as we traverse it. We can look at the `M1`

case because it's babby's first instance when compared to `K1`

:

```
instance (GLenses z i o)
=> GLenses z (M1 _a _b i) (M1 _a _b o) where
glenses l = M1 $ glenses $ \f -> l $ fmap M1 . f . unM1
{-# INLINE glenses #-}
```

Here we're saying we can lift a `GLenses z i o`

over an `M1`

constructor by calling `glenses`

with an updated lens that will burrow through the `M1`

-ness. This transformation is completely analogous to the one we did for `K1`

. Once we have our generated lenses, we need to re-wrap the structure in an `M1`

constructor so we can transform it back into our HKD representation.

The product case looks a little trickier, but it's only because `GHC.Generics`

doesn't provide us with any useful un/wrapping combinators for the `(:*:)`

constructor.

```
instance (GLenses z i o, GLenses z i' o')
=> GLenses z (i :*: i') (o :*: o') where
glenses l = glenses (\f -> l (\(a :*: b) -> fmap (:*: b) $ f a))
:*: glenses (\f -> l (\(a :*: b) -> fmap (a :*:) $ f b))
{-# INLINE glenses #-}
```

We finish it off with the trivial instances for `V1`

and `U1`

:

```
instance GLenses z V1 V1 where
glenses l = undefined
instance GLenses z U1 U1 where
glenses l = U1
```

And voila! Our induction is complete. Notice that we *did not* write an instance for `(:+:)`

(coproducts), because lenses are not defined for coproduct types. This is fine for our `Person'`

case, which has no coproducts, but types that do will simply be unable to find a `GLenses`

instance, and will fail to compile. No harm, no foul.

With this out of the way, we need to write our final interface that will use all of the generic machinery and provide nice access to all of this machinery. We're going to need to call `glenses`

(obviously), and pass in a `Lens' (z Identity) (Rep (z Identity))`

in order to get the whole thing running. Then, once everything is build, we'll need to call `to`

to turn our generic representation back into the HKD representation.

But how can we get a `Lens'(z Identity) (Rep (z Identity))`

? Well, we know that `GHC.Generics`

gives us an isomorphism between a type and its `Rep`

, as witnessed by `to`

and `from`

. We further know that every `Iso`

is indeed a `Lens`

, and so the lens we want is just `iso from to`

. Our function, then, is "simply":

```
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
getLenses
:: forall z
. ( Generic (z Identity)
, Generic (z (LensFor (z Identity)))
, GLenses z (Rep (z Identity))
(Rep (z (LensFor (z Identity))))
)
=> z (LensFor (z Identity))
getLenses = to $ glenses @z $ iso from to
```

where I just wrote the `z (LensFor (z Identity))`

part of the type signature, and copy-pasted constraints from the error messages until the compiler was happy.

OK, so let's take it for a spin, shall we? We can get our lenses thusly:

`Person (LensFor lName) (LensFor lAge) = getLenses`

Yay! Finally we can ask GHCi for their types, which is a surprisingly satisfying experience:

```
> :t lName
lName :: Lens' (Person' Identity) String
```

Pretty sweet, ne? Now that `getLenses`

has been implemented generically, it can become library code that will work for any product-type we can throw at it. Which means free lenses without TemplateHaskell for any types we define in the HKD form.

This HKD pattern is useful enough that I've begun implement literally all of my "data" (as opposed to "control") types as higher-kinded data. With an extra type synonym `type X = X' Identity`

, and `{-# LANGUAGE TypeSynonymInstances #-}`

, nobody will ever know the difference, except that it affords me the ability to use all of this stuff in the future should I want to.

As Conal says, all of this stuff might not necessarily be "for free" but at the very least, it's "already paid for."

More shoutouts to Travis Athougies, whose sweet library beam uses this approach to generate lenses for working with SQL tables. I consulted the beam source more than a couple times in writing this post. Thanks again, Travis!

]]>`sequence`

over data-types; and automatically track dependencies for usages of record fields.
As for this post, we'll look at how to build type-level sequencing, and investigate some other uses in subsequent ones. For our examples, let's define the following (completely arbitrary) data-type:

```
data Person = Person
{ pName :: String
, pAge :: Int
} deriving (Generic)
```

That's cool and all, I guess. For purposes of discussion, let's imagine that we want to let the user fill in a `Person`

via a web-form or something. Which is to say, it's possible they'll screw up filling in some piece of information without necessarily invalidating the rest of the datastructure. If they successfully filled in the entire structure, we'd like to get a `Person`

out.

One way of modeling this would be with a second datatype:

```
data MaybePerson = MaybePerson
{ mpName :: Maybe String
, mpAge :: Maybe Int
} deriving (Generic)
```

and a function:

```
validate :: MaybePerson -> Maybe Person
validate (MaybePerson name age) =
Person <$> name <*> age
```

This works, but it's annoying to write by hand, since it's completely mechanical. Furthermore, having duplicated this effort means we'll need to use our brains in the future to make sure all three definitions stay in sync. Wouldn't it be cool if the compiler could help with this?

SURPRISE! IT CAN! And that's what I want to talk about today.

Notice that we can describe both `Person`

and `MaybePerson`

with the following higher-kinded data (henceforth "**HKD**") definition:

```
data Person' f = Person
{ pName :: f String
, pAge :: f Int
} deriving (Generic)
```

Here we've parameterized `Person'`

over something `f`

(of kind `* -> *`

), which allows us to do the following in order to get our original types back:

```
type Person = Person' Identity
type MaybePerson = Person' Maybe
```

While this works, it's kind of annoying in the `Person`

case, since now all of our data is wrapped up inside of an `Identity`

:

```
> :t pName @Identity
pName :: Person -> Identity String
> :t runIdentity . pName
runIdentity . pName :: Person -> String
```

We can fix this annoyance trivially, after which we will look at why defining `Person'`

as such is actually useful. To get rid of the `Identity`

s, we can use a type family (a function at the type-level) that erases them:

```
{-# LANGUAGE TypeFamilies #-}
-- "Higher-Kinded Data"
type family HKD f a where
HKD Identity a = a
HKD f a = f a
data Person' f = Person
{ pName :: HKD f String
, pAge :: HKD f Int
} deriving (Generic)
```

Using the `HKD`

type family means that GHC will automatically erase any `Identity`

wrappers in our representations:

```
> :t pName @Identity
pName :: Person -> String
> :t pName @Maybe
pName :: Person -> Maybe String
```

and with that, the higher-kinded version of `Person`

can be used as a drop-in replacement for our original one. The obvious question is what have we bought ourselves with all of this work. Let's look back at `validate`

to help us answer this question. Compare our old implementation:

```
validate :: MaybePerson -> Maybe Person
validate (MaybePerson name age) =
Person <$> name <*> age
```

with how we can now rewrite it with our new machinery:

```
validate :: Person' Maybe -> Maybe Person
validate (Person name age) =
Person <$> name <*> age
```

Not a very interesting change is it? But the intrigue lies in how little needed to change. As you can see, only our type and pattern match needed to change from our original implementation. What's neat here is that we have now consolidated `Person`

and `MaybePerson`

into the same representation, and therefore they are no longer related only in a nominal sense.

We can write a version of `validate`

that will work for any higher-kinded datatype.

The secret is to turn to `GHC.Generics`

. If you're unfamiliar with them, they provide an isomorphism from a regular Haskell datatype to a generic representation that can be structurally manipulated by a clever programmer (ie: us.) By providing code for what to do for constant types, products and coproducts, we can get GHC to write type-independent code for us. It's a really neat technique that will tickle your toes if you haven't seen it before.

To start with, we need to define a typeclass that will be the workhorse of our transformation. In my experience, this is always the hardest part -- the types of these generic-transforming functions are exceptionally abstract and in my opinion, very hard to reason about. I came up with this:

```
{-# LANGUAGE MultiParamTypeClasses #-}
class GValidate i o where
gvalidate :: i p -> Maybe (o p)
```

I only have "soft-and-slow" rules for reasoning about what your typeclass should look like, but in general you're going to need both an `i`

nput and an `o`

utput parameter. They both need to be of kind `* -> *`

and then be passed this existentialized `p`

, for dark, unholy reasons known not by humankind. I then have a little checklist I walk through to help me wrap my head around this nightmarish hellscape that we'll walk through in a later installment of the series.

Anyway, with our typeclass in hand, it's now just a matter of writing out instances of our typeclass for the various GHC.Generic types. We can start with the base case, which is we should be able to validate a `Maybe k`

:

```
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
instance GValidate (K1 a (Maybe k)) (K1 a k) where
-- gvalidate :: K1 a (Maybe k) -> Maybe (K1 a k)
gvalidate (K1 k) = K1 <$> k
{-# INLINE gvalidate #-}
```

`K1`

represents a "constant type", which is to say that it's where our structural recursion conks out. In our `Person'`

example, it's the `pName :: HKD f String`

bit.

Most of the time, once you have the base case in place, the rest is to just mechanically provide instances for the other types. Unless you need to access metadata about the original type anywhere, these instances will almost always be trivial homomorphisms.

We can start with products -- if we have `GValidate i o`

and `GValidate i' o'`

, we should be able to run them in parallel:

```
instance (GValidate i o, GValidate i' o')
=> GValidate (i :*: i') (o :*: o') where
gvalidate (l :*: r) = (:*:)
<$> gvalidate l
<*> gvalidate r
{-# INLINE gvalidate #-}
```

If `K1`

referred directly to the selectors of our `Person'`

, `(:*:)`

corresponds roughly to the `,`

piece of syntax we separate our record fields with.

We can define a similar instance of `GValidate`

for coproducts (corresponding to a `|`

in a data definition):

```
instance (GValidate i o, GValidate i' o')
=> GValidate (i :+: i') (o :+: o') where
gvalidate (L1 l) = L1 <$> gvalidate l
gvalidate (R1 r) = R1 <$> gvalidate r
{-# INLINE gvalidate #-}
```

Furthermore, if we don't care about looking at metadata, we can simply lift a `GValidate i o`

over the metadata constructor:

```
instance GValidate i o
=> GValidate (M1 _a _b i) (M1 _a' _b' o) where
gvalidate (M1 x) = M1 <$> gvalidate x
{-# INLINE gvalidate #-}
```

Just for kicks, we can provide the following trivial instances, for uninhabited types (`V1`

) and for constructors without any parameters (`U1`

):

```
instance GValidate V1 V1 where
gvalidate = undefined
{-# INLINE gvalidate #-}
instance GValidate U1 U1 where
gvalidate U1 = Just U1
{-# INLINE gvalidate #-}
```

The use of `undefined`

here is safe, since it can only be called with a value of `V1`

. Fortunately for us, `V1`

is uninhabited, so this can never happen, and thus we're morally correct in our usage of `undefined`

.

Without further ado, now that we have all of this machinery out of the way, we can finally write a non-generic version of `validate`

:

```
{-# LANGUAGE FlexibleContexts #-}
validate
:: ( Generic (f Maybe)
, Generic (f Identity)
, GValidate (Rep (f Maybe))
(Rep (f Identity))
)
=> f Maybe
-> Maybe (f Identity)
validate = fmap to . gvalidate . from
```

I always get a goofy smile when the signature for my function is longer than the actual implementation; it means we've hired the compiler to write code for us. What's neat about `validate`

here is that it doesn't have any mention of `Person'`

; this function will work for *any* type defined as higher-kinded data. Spiffy.

That's all for today, folks. We've been introduced to the idea of higher-kinded data, seen how it's completely equivalent with a datatype defined in a more traditional fashion, and also caught a glimmer of what kind of things are possible with this approach. This is where we stop for today, but in the next post we'll look at how we can use the HKD approach to generate lenses without resorting to TemplateHaskell.

Happy higher-kinding!

Big shoutouts to Travis Athougies from whom I originally learned this technique, and to Ariel Weingarten and Fintan Halpenny for proofreading earlier versions of this post.

]]>The first thing we need to do is indicate to the game which parts of the background should be walkable. Like we did for marking hotspots, we'll use an image mask. Since we have way more density in an image than we'll need for this, we'll overlay it on the hotspot mask.

Again, if the room looks like this:

Our mask image would look like this:

Here, the walkable section of the image is colored in blue. You'll notice there's a hole in the walk mask corresponding to the table in the room; we wouldn't want our avatar to find a path that causes him to walk through the table.

However there is something important to pay attention to here; namely that we're making an adventure game. Which is to say that our navigation system doesn't need to be all that good; progress in the game is blocked more by storytelling and puzzles than it is by the physical location of the player (unlike, for example, in a platformer game.) If the avatar does some unnatural movement as he navigates, it might be *immersion-breaking*, but it's not going to be *game-breaking*.

Which means we can half ass it, if we need to. But I'm getting ahead of myself.

The first thing we're going to need is a function which samples our image mask and determines if a given position is walkable.

```
canWalkOn :: Image PixelRGBA8 -> V2 Int -> Bool
canWalkOn img (V2 x y)
= flip testBit walkableBit
. getWalkableByte
$ pixelAt img x y
where
getWalkableByte (PixelRGBA8 _ _ b _) = b
walkableBit = 7
```

Currying this function against our image mask gives us a plain ol' function which we can use to query walk-space.

In a 3D game, you'd use an actual mesh to mark the walkable regions, rather than using this mask thing. For that purpose, from here on out we'll call this thing a navmesh, even though it isn't strictly an appropriate name in our case.

Because pathfinding algorithms are defined in terms of graphs, the next step is to convert our navmesh into a graph. There are lots of clever ways to do this, but remember, we're half-assing it. So instead we're going to do something stupid and construct a square graph by sampling every *n* pixels, and connecting it to its orthogonal neighbors if both the sample point and its neighbor are walkable.

It looks like this:

Given the navmesh, we sample every *n* points, and determine whether or not to put a graph vertex there (white squares are vertices, the black squares are just places we sampled.) Then, we put an edge between every neighboring vertex (the white lines.)

We're going to want to run A* over this graph eventually, which is implemented in Haskell via `Data.Graph.AStar.aStar`

. This package uses an implicit representation of this graph rather than taking in a graph data structure, so we'll construct our graph in a manner suitable for `aStar`

.

But first, let's write some helper functions to ensure we don't get confused about whether we're in world space or navigation space.

```
-- | Sample every n pixels in on the navmesh.
sampleRate :: Float
sampleRate = 4
-- | Newtype to differentiate nav node coordinates from world coordinates.
newtype Nav = Nav { unNav :: Int }
deriving (Eq, Ord, Num, Integral, Real)
toNav :: V2 Float -> V2 Nav
toNav = fmap round
. fmap (/ sampleRate)
fromNav :: V2 Nav -> V2 Float
fromNav = fmap (* sampleRate)
. fmap fromIntegral
```

`toNav`

and `fromNav`

are roughly inverses of one another -- good enough for half-assing it at least. We'll do all of our graph traversal stuff in nav-space, and use world-space only at the boundaries.

We start with some helper functions:

```
navBounds :: Image a -> V2 Nav
navBounds = subtract 1
. toNav
. fmap fromIntegral
. imageSize
```

`navBound`

gives us the largest valid navigation point from an image -- this will be useful later when we want to build a graph and *don't* want to sample points that are not on it.

The next step is our `neighbors`

function, which should compute the edges for a given node on the navigation step.

```
neighbors :: Image PixelRGBA8 -> V2 Nav -> HashSet (V2 Nav)
neighbors img v2 = HS.fromList $ do
let canWalkOn' = canWalkOn img
. fmap floor
. fmap fromNav
V2 x y <- fmap (v2 &)
[ _x -~ 1
, _x +~ 1
, _y -~ 1
, _y +~ 1
]
guard $ canWalkOn' v2
guard $ x >= 0
guard $ x <= w
guard $ y >= 0
guard $ y <= h
guard . canWalkOn' $ V2 x y
return $ V2 x y
```

We use the list monad here to construct all of the possible neighbors -- those which are left, right, above and below our current location, respectively. We then guard on each, ensure our current nav point is walkable, that our candidate neighbor is within nav bounds, and finally that the candidate itself is walkable. We need to do this walkable check last, since everything will explode if we try to sample a pixel that is not in the image.

Aside: if you actually have a mesh (or correspondingly a polygon in 2D), you can bypass all of this sampling nonsense by tessellating the mesh into triangles, and using the results as your graph. In my case I didn't have a polygon, and I didn't want to write a tessellating algorithm, so I went with this route instead.

Finally we need a distance function, which we will use both for our astar heuristic as well as our actual distance. The actual distance metric we use doesn't matter, so long as it corresponds monotonically with the actual distance. We'll use distance squared, because it has this monotonic property we want, and saves us from having to pay the cost of computing square roots.

```
distSqr :: V2 Nav -> V2 Nav -> Float
distSqr x y = qd (fmap fromIntegral x) (fmap fromIntegral y)
```

And with that, we're all set! We can implement our pathfinding by filling in all of the parameters to `aStar`

:

```
pathfind :: Image PixelRGBA8 -> V2 Float -> V2 Float -> Maybe [V2 Float]
pathfind img = \src dst ->
fmap fromNav <$> aStar neighbors distSqr (distSqr navDst) navSrc
where
navSrc = toNav src
navDst = toNav dst
```

Sweet. We can run it, and we'll get a path that looks like this:

Technically correct, in that it does in fact get from our source location to our destination. But it's obviously half-assed. This isn't the path that a living entity would take; as a general principle we try not to move in rectangles if we can help it.

We can improve on this path by attempting to shorten it. In general this is a hard problem, but we can solve that by giving it the old college try.

Our algorithm to attempt to shorten will be a classic divide and conquer approach -- pick the two endpoints of your current path, and see if there is a straight line between the two that is walkable throughout its length. If so, replace the path with the line you just constructed. If not, subdivide your path in two, and attempt to shorten each half of it.

Before we actually get into the nuts and bolts of it, here's a quick animation of how it works. The yellow circles are the current endpoints of the path being considered, and the yellow lines are the potential shortened routes. Whenever we can construct a yellow line that doesn't leave the walkable region, we replace the path between the yellow circles with the line.

The "divide and conquer" bit of our algorithm is easy to write. We turn our path list into a `Vector`

so we can randomly access it, and then call out to a helper function `sweepWalkable`

to do the nitty gritty stuff. We append the `src`

and `dst`

to the extrema of the constructed vector because `aStar`

won't return our starting point in its found path, and because we quantized the `dst`

when we did the pathfinding, so the last node on the path is the closest navpoint, rather than being where we asked the character to move to.

```
shorten :: Image PixelRGBA8 -> V2 Float -> V2 Float -> [V2 Float] -> [V2 Float]
shorten img src dst path =
let v = V.fromList $ (src : path) ++ [dst]
in go 0 (V.length v - 1) v
where
go l u v =
if sweepWalkable img (v V.! l) (v V.! u)
then [v V.! u]
else let mid = ((u - l) `div` 2) + l
in go l mid v ++ go mid u v
```

The final step, then, is to figure out what this `sweepWalkable`

thing is. Obviously it wants to construct a potential line between its endpoints, but we don't want to have to sample every damn pixel. Remember, we're half-assing it. Instead, we can construct a line, but actually only sample the nav points that are closest to it.

In effect this is "rasterizing" our line from its vector representation into its pixel representation.

Using the Pythagorean theorem in navigation space will give us the "length" of our line in navigation space, which corresponds to the number of navpoints we'll need to sample.

For example, if our line looks like this:

Then the number *n* of nav points we need to sample is:

$$
\begin{align*}
n &= \lfloor \sqrt{4^2 + 5^2} \rfloor \\
&= \lfloor \sqrt{16 + 25} \rfloor \\
&= \lfloor \sqrt{41} \rfloor \\
&= \lfloor 6.4 \rfloor \\
&= 6
\end{align*}
$$

We can then subdivide our line into 6 segments, and find the point on the grid that is closest to the end of each. These points correspond with the nodes that need to be walkable individually in order for our line itself to be walkable. This approach will fail for tiny strands of unwalkable terrain that slices through otherwise walkable regions, but maybe just don't do that? Remember, all we want is for it to be good enough -- half-assing it and all.

So, how do we do it?

```
sweepWalkable :: Image PixelRGBA8 -> V2 Float -> V2 Float -> Bool
sweepWalkable img src dst =
let dir = normalize $ dst - src
distInNavUnits = round $ distance src dst
bounds = navBounds img
in getAll . flip foldMap [0 .. distInNavUnits] $ \n ->
let me = src + dir ^* (fromIntegral @Int n)
in All . canWalkOn' img
. clamp (V2 0 0) bounds
$ toNav me
```

Sweet! Works great! Our final pathfinding function is thus:

```
navigate :: Image PixelRGBA8 -> V2 Float -> V2 Float -> Maybe [V2 Float]
navigate img src dst = fmap (shorten img src dst) $ pathfind src dst
```

Golden, baby.

Next time we'll talk about embedding a scripting language into our game so we don't need to wait an eternity for GHC to recompile everything whenever we want to change a line of dialog. Until then!

]]>An adventure game in which you're unable to interact with anything isn't much of a game, and that's where we left the engine. So it seemed like a thing to focus on next.

I knew that click/hold interaction that I wanted formed some sort of DFA, so I unwisely headed down that garden path for a bit. After implementing a bit, I found a state machine with the denotation of `type DFA s e a = s -> e -> Either s a`

, where `s`

is the state of the machine, `e`

is the type of an edge transition, and `a`

is the eventual output of the machine. Upon the final result, however, it became clear that I had fallen into an abstraction hole. I spent a bunch of time figuring out the implementation of this thing, and then afterwards realized it didn't actually solve my problem. Whoops. Amateur Haskell mistake :)

The problem is that transitioning into some state might need to make a monadic action in order to generate the next edge. For example, when you press down on the mouse button, we need to start a timer which will open the action menu when it expires. This could be alleviated by changing `Either`

to `These`

and letting `a ~ (Monad m => m b)`

, but that struck me as a pretty ugly hack, and getting the implementation of the denotation to work again was yucky.

So I decided that instead maybe I should write a dumb version of what I wanted, and find out how to abstract it later if I should need similar machinery again in the future. I burned my `DFA`

implementation in a fire.

This posed a problem, though, because if I wanted to write this for real I was going to need things to actually interact with, and I didn't yet have those. I decided to put the interaction sprint on hold, in order to focus more on having things with which to interact.

One abstraction I think in terms of when working with adventure games is that of the **hotspot**. A hotspot is a mask on the background image which indicates a static piece of interesting geometry. For example, a window that never moves would be baked into the background image of the room, and then a hotspot would be masked on top of it to allow the character to interact with it.

For example, if our room looks like this (thanks to MI2 for the temporary art):

Then our mask image would look like this:

We can add some logic to be able to read the mask:

```
mkHotspot
:: Image PixelRGBA8
-> (Word8 -> Bool)
-> Hotspot
-> Pos
-> Maybe Hotspot
mkHotspot img f h = bool Nothing (Just h)
. f
. getHotspotByte
. uncurry (pixelAt img)
. (\(V2 x y) -> (x, y))
. clampToWorld
. fmap round
where
clampToWorld = clamp (V2 0 0) $ imageSize img
getHotspotByte (PixelRGBA8 _ g _ _) = g
```

and now bake the first three parameters of this function when we construct our level definition.

In order to test these things, I gave added a field `_hsName :: Hotspot -> String`

in order to be able to test if my logic worked. The next step was to bind the click event to be able to call the `Pos -> Maybe Hotspot`

that I curried out of `mkHotspot`

and stuck into my `Room`

datastructure (`_hotspots :: Room -> Pos -> Maybe Hotspot`

).

I clicked around a bunch, and found that `print . fmap _hsName $ _hotspots currentRoom mousePos`

lined up with the door when I clicked on it. It seemed to be working, so I considered my first yak shave successful: I now had something in the world that I could interact with.

The next step was to code up a little bit of the DFA I was originally working on. I decided that I should make the avatar walk to the place you clicked if it wasn't a hotspot.

```
case event of
MouseButton Down ->
case _hotspots currentRoom mousePos of
Just hs ->
print $ _hsName hs
Nothing ->
when (isWalkable (_navmesh currentRoom) mousePos) $
emap $ do
with isAvatar
pure defEntity'
{ pathing = Set $ NavTo mousePos
}
```

So: when the mouse is pressed, see if it was over top of a hotspot. If so, print out the name of it. Otherwise, check the navmesh of the room, and see if that's a valid place to walk. If so, update any entity who has the `isAvatar`

component and set its `pathing`

component to be the location we want.

The engine at this point already has navigation primitives, which is why this works. We'll discuss how the navmesh is generated and used in another devlog post.

I ran this code and played around with it for a while. Everything looked good -- after I remembered to set `isAvatar`

on my player entity :)

The next step was to implement timers that would have a callback, and could be started and stopped. I'd need support for these in order to wait a little bit before opening up the action menu. Thankfully, timers are super easy: just have an amount of time you decrement every frame until it hits zero, and then do the necessary action. I came up with this model for timers:

```
data Timer = Timer
{ _tTime :: Time
, _tCallback :: Game ()
}
data TimerType
= TimerCoin
deriving (Eq, Ord)
data GlobalState = GlobalState
{ ... -- other stuff
, _timers :: Map TimerType Timer
}
```

A `Timer`

is just an amount of remaining time and something to do afterwards. It's stored in the `GlobalState`

with a `TimerType`

key. I originally thought about using a bigger type (such as `Int`

) as my timer key, but realized that would make canceling specific timers harder as it would imply they're given a non-deterministic key when started. The interface for starting and canceling timers turned out to be trivial:

```
startTimer :: TimerType -> Time -> Game () -> Game ()
startTimer tt t cb =
setGlobals $ timers . at tt ?~ Timer t cb
cancelTimer :: TimerType -> Game ()
cancelTimer tt =
setGlobals $ timers . at tt .~ Nothing
```

The only thing left is to update timers and run their callbacks when it's time. I fucked around with this implementation too hard, trying to find a completely lensy way of doing it, but eventually settled on this ugly `fromList . toList`

thing:

```
updateTimers :: Time -> Game ()
updateTimers dt = do
ts <- getGlobals $ view timers
ts' <- forOf traverse ts $ \t ->
if _tTime t - dt <= 0
then _tCallback t $> Nothing
else pure . Just
$ t & tTime -~ dt
setGlobals $
timers .~ M.fromList (catMaybes . fmap sequence $ M.toList ts')
```

`ts'`

is a traversal over the `Map`

of timers, that decrements each of their times, optionally runs their callbacks, then returns a `Mayber Timer`

for each one. The last line is where the interesting bit is -- `sequence`

over a `(TimerType, Maybe Timer)`

is a `Maybe (TimerType, Timer)`

, which we can then insert back into our `Map`

as we construct it -- essentially filtering out any timers which have expired.

Finally we can get back to our DFA. Instead of printing out the name of the hotspot you clicked on, we can now start a timer that will update our game state. I added a field to `GlobalState`

:

```
data GlobalState = GlobalState
{ ... -- other stuff
, _gInputDFA :: InputDFA
}
data InputDFA
= IStart
| IBeforeCoin
| ICoinOpen Pos HotSpot
deriving (Eq, Ord)
```

The idea is that we start in state `IStart`

, transition into `IBeforeCoin`

when we start the timer, and into `ICoinOpen`

when the timer expires. Additionally, if the user releases the mouse button, we want to cancel the timer. All of this becomes:

```
case (_gInputDFA globalState, event) of
(IStart, MouseButton Down) ->
case _hotspots currentRoom mousePos of
Just hs -> do
startTimer TimerCoin 0.5 $ do
setGlobals $ gInputDFA .~ ICoinOpen mousePos hs
setGlobals $ gInputDFA .~ IBeforeCoin
Nothing ->
-- as before
(IBeforeCoin, MouseButton Up) -> do
cancelTimer TimerCoin
setGlobals $ gInputDFA .~ IStart
(ICoinOpen p hs, MouseButton Up) -> do
let verb = getBBSurface (coinSurface p) mousePos
for_ verb $ doInteraction hs
setGlobals $ gInputDFA .~ IStart
```

If you care, try to trace through these cases and convince yourself that this logic is correct. The reason we have a position stored inside the `ICoinOpen`

is so that we know where the mouse was when the user started holding their mouse down. This corresponds to where we should draw the action menu.

This is done in the drawing routine by checking the current state of `_gInputDFA`

-- if it's `ICoinOpen`

it means the menu is up and we need to draw it.

The only last thing is how can we map where you release your mouse button on the menu to what interaction we should do. Our action menu looks like this:

From left to right, these squares represent talking/eating, examining, and manipulating. We need some way of mapping a location on this image to a desired outcome.

Doing rectangle collision is easy enough -- we define a bounding box and a test to see if a point is inside of it (as well as some auxiliary functions for constructing and moving `BB`

s, elided here):

```
data BB = BB
{ leftX :: Float
, rightX :: Float
, topY :: Float
, bottomY :: Float
} deriving (Eq, Ord, Show)
inBB :: BB -> Pos -> Bool
inBB BB{..} (V2 x y) = and
[ x >= leftX
, x < rightX
, y >= topY
, y < bottomY
]
rectBB :: Float -> Float -> BB
moveBB :: Pos -> BB -> BB
```

The final step is to somehow map these bounding boxes to things we want to return. This seems like it'll be a recurring theme, so we build some machinery for it:

```
data BBSurface a = BBSurface [(BB, a)]
deriving (Eq, Ord, Show)
getBBSurface :: BBSurface a -> Pos -> Maybe a
getBBSurface (BBSurface bs) p =
getFirst . flip foldMap bs $ \(b, a) ->
if inBB b p
then First $ Just a
else First $ Nothing
```

The abstraction is my amazingly-named `BBSurface`

, which is a mapping of `BB`

s to values of some type `a`

. We can find a `Maybe a`

on the `BBSurface`

by just checking if the point is in any of the bounding boxes. If it is, we return the first value we find.

All that's left is to construct one of these `BBSurface`

s for the coin, and then to move it to the position indicated inside the `ICoinOpen`

. Easy as pie. Pulling everything together, and our interactive menu works as expected. Great success!

Next time we'll talk about navigation. Thanks for reading!

]]>Perhaps you could explain a little bit about your choice to write ecstasy rather than to use apecs? I've not used apecs, I'm just interested as I had done some limited research into writing games in Haskell and apecs seemed to have traction.

That seems like a really good idea, and combined with the fact that I really haven't published anything about `ecstasy`

suggested I actually write about it!

So before diving in, let's take a look at the problem an entity-component-system (ECS) solves. Let's say we're writing a simple 2D platformer, we'll have dudes who can run around and jump on platforms.

The way I'd go about writing this before knowing about ECS would be to implement one feature at a time, generally using the player character to test it as I went. I write functions that look something like this:

```
moveActor :: Controller -> Actor -> Actor
moveActor ctrl actor =
actor & actorPos +~ movingDirection ctrl
```

and then provide some types to hold all of the world together:

```
data Universe = Universe
{ _uPlayer :: Actor
, _uPlayerCtrl :: Controller
, _uCurrentLevel :: Level
}
data Level = Level
{ _lActors :: [Actor]
}
```

and finally write some glue code to lift `moveActor`

over the universe.

```
updateUniverse :: Universe -> Universe
updateUniverse u@Universe{..} =
u & uPlayer %~ moveActor _uPlayerCtrl
& uCurrentLevel . lActors . traverse %~ moveActor someCtrl
```

On the surface this feels good. We've reused the code for `moveActor`

for both the player and any other dudes on the level who might want to walk around. It feels like we can build up from here, and compose pieces as we go.

Which is true if you're really patient, good at refactoring, or have spent a lot of time building things like this and know where you're going to run afoul. Because you're always going to run afoul in software.

The problem with our first attempt at this code is that it codifies a lot of implicit assumptions about our game. For example, did you notice that it implies we'll always have an `Actor`

for the player? It seems like a reasonable assumption, but what if you want to play a cut-scene? Or how about if you don't want to always have control over the player? Maybe you've just been hit by something big that should exert some acceleration on you, and you don't want to be able to just press the opposite direction on the control stick to negate it.

All of a sudden, as you try to code for these things, your simple `moveActor`

function takes more and more parameters about the context of the circumstances in which it's running. And what's worse is that often the rules of how these behaviors should play out will change depending on whether its the player or some enemy in the level. We're left with a conundrum -- should we build ad-hoc infrastructure around the callers of `moveActor`

or should we put all of the logic inside of it?

As you can imagine, it pretty quickly becomes a mess.

In one of the few times I'll praise object-oriented programming, I have to say that its inheritance-based polymorphism lends itself well to this problem. You can build more complicated and specific behaviors out of your ancestors' behaviors. Unfortunately, this approach bucks the OOP best-practice of "composition over inheritance."

ECS takes what I consider to be the functional-programming-equivalent of this OOP strategy. It's fundamental stake in the ground is that rather than representing your universe of game objects as an array-of-structs, you instead represent it as a struct-of-arrays. Conceptually, this is a cognitive shift that means instead of looking like this:

```
data GameObject = GameObject
{ position :: V2
, velocity :: V2
, graphics :: Picture
, buffs :: [Buff]
, notAffectedByGravity :: Bool
}
type Universe = [GameObject]
```

you instead model the domain like this:

```
data Universe = Universe
{ position :: Array V2
, velocity :: Array V2
, graphics :: Array Picture
, buffs :: Array [Buff]
, notAffectedByGravity :: Array Bool
}
```

This has some profound repercussions. First of all, notice that we have no guarantee that our `Array`

s are the same length, which implies that not every `GameObject`

need have all of its possible components.

All of a sudden, we can pick and choose which components an entity has. Entities, now instead of being explicitly modeled by a `GameObject`

are implicitly defined by an `Int`

corresponding to their index in all of the arrays.

From here, we can now write specific, *global* behaviors that should manipulate the components of an entity. We can avoid a lot of our previous ad-hoc machinery by essentially running a `map`

that performs pattern matching on only the components we want to care about. For example, we can say that we only want to draw entities who have both a `position`

and a `graphics`

. We want to apply gravity to all entities that have a `velocity`

, but *don't* have the `notAffectedByGravity`

flag.

*EDIT 2018-01-30*: The author of apecs has replied to this post. It's worth reading through, as it gives a useful perspective from the other side.

With an understanding of what ECS brings to the table, we're now ready to take a look at different ways of implementing such a system. We first turn our attention to apecs.

If we wanted to model our above `GameObject`

via `apecs`

, it might look something like this:

```
newtype Position = Position (V2 Double)
instance Component Position where
type Storage Position = Map Position
newtype Velocity = Velocity (V2 Double)
instance Component Velocity where
type Storage Velocity = Map Velocity
newtype Graphics = Graphics Picture
instance Component Graphics where
type Storage Graphics = Map Graphics
newtype Buffs = Buffs [Buff]
instance Component Buffs where
type Storage Buffs = Map Buffs
newtype NotAffectedByGravity = NotAffectedByGravity
instance Flag NotAffectedByGravity where
flag = NotAffectedByGravity
instance Component NotAffectedByGravity where
type Storage NotAffectedByGravity = Set NotAffectedByGravity
makeWorld "World"
[ ''Position
, ''Velocity
, ''Graphics
, ''Buffs
, ''NotAffectedByGravity
]
```

You'll have to admit it's a lot of boilerplate, which in turn would use Template Haskell to generate something similar to our conceptual `Universe`

above:

```
data World = World
{ position :: Array (Maybe Position)
, velocity :: Array (Maybe Velocity)
, graphics :: Array (Maybe Graphics)
, buffs :: Array (Maybe Buffs)
, notAffectedByGravity :: Set Int
}
```

I haven't dug too much into the internals of `apecs`

, so this representation might not be perfect, but it's good enough for us to get an understanding of what's going on here.

We can now use some of `apecs`

' primitives to, for example, transfer our velocity over to our position:

`rmap $ \(Position p, Velocity v) -> Position $ p + v`

This `rmap`

function is something I'd describe as "fucking magic." You pass it a lambda, it inspects the type of the lambda, uses the tuple of its input to determine which components an entity must have, and then will update the components of the corresponding output tuple.

At first, this seems like a fine abstraction, but it breaks down pretty quickly when used in anger. For example, what if you want to run a function over `Position`

that only works if you *don't* have a `Velocity`

? Or if you want to remove a component from an entity? `apecs`

can do it, but good luck finding the right function. Do you want `cmap`

, `cmapM`

, `cmapM_`

, `cimapM`

, `cimapM_`

, `rmap'`

, `rmap`

, `wmap`

, `wmap'`

or `cmap'`

? After a week of working with the library, I still couldn't come up with heads or tails for which function I needed in any circumstance. I'm sure there's a mnemonic here somewhere, but I'm not bright enough to figure it out.

When you do eventually find the right function, doing anything other than a pure map from one component to another becomes an exercise in futility and magic pattern matching. There's this thing called `Safe`

you sometimes need to pattern match over, or produce, and it roughly corresponds to when you're not guaranteed to have all of the components you asked for.

There are several other gotchas, too. For example, you can construct an entity by providing a tuple of the components you want to set. Unfortunately, due to `apecs`

' design, this thing *must be type-safe.* Which means you can't construct one based on runtime data if you're loading the particular components from e.g. a level editor. Well, you can, if you're willing to play "existentialize the dictionary" and learn enough of the underlying library (and quirks of Haskell's type inference algorithm) in order to convince the compiler what you're doing is sound.

One final gotcha I'll mention is that this magic tuple stuff is provided through typeclasses which are generated for the library by template haskell. Out of the box, you only get support for 5-tuples, which means you can't easily construct entities with more components than that. Furthermore, changing the TH to generate more results in exponential growth of your compile times.

None of this is to say that `apecs`

is bad software. It's actually pretty brilliant in terms of its technology; I just feel as though its execution is lacking. It depends on a lot of tricks that I wouldn't consider to be idiomatic Haskell, and its usability suffers as a consequence.

So with all of the above frustrations in mind, and a lot of time to kill in a Thai airport, I felt like I could make a better ECS. Better is obviously subjective for things like this, but I wanted to optimize it for being used by humans.

My explicit desiderata were:

- Keep boilerplate to a minimum.
- The user shouldn't ever bump into any magic.

I think `ecstasy`

knocks it out of the park on both of these fronts. Before diving into how it all works, let's take a peek at how it's used. We can define our components like so:

```
data EntWorld f = Entity
{ position :: Component f 'Field V2
, velocity :: Component f 'Field V2
, graphics :: Component f 'Field Picture
, buffs :: Component f 'Field [Buff]
, notAffectedByGravity :: Component f 'Field ()
} deriving (Generic)
type Entity = EntWorld 'FieldOf
```

That's it! No template haskell, no typeclasses, no nothing. You get everything for free just out of this one `deriving Generic`

statement. We'll talk about how it works in just a second.

We can implement the velocity/position behavior as follows:

```
emap $ do
p <- get position
v <- get velocity
pure defEnt'
{ position = Set $ p + v
}
```

Ecstasy clearly wins on minimizing the definition-side of boilerplate, but it seems like we've gained some when we actually go to use these things. This is true, but what we buy for that price is flexibility. In fact, `emap`

is powerful enough to set, unset and keep components, as well as branch on whether or not a component is actually there. Compare this to the ten functions with different signatures and semantics that you need to keep in mind when working with `apecs`

, and it feels like more of a win than the syntax feels like a loss.

So the question I'm sure you're wondering is "how does any of this work?" And it's a good question. Part of the reason I wrote this library was to get a feel for the approach and for working with GHC.Generics.

The idea comes from my colleague Travis Athougies and his mind-meltingly cool library `beam`

. The trick is to get the library user to define one semantic type that makes sense in their domain, and then to use tricky type system extensions in order to corral it into everything you need. `beam`

uses this approach to model database tables; `ecstasy`

uses it to provide both a struct-of-arrays for your components, as well as just a struct corresponding to a single entity.

As you'd expect, the sorcery is inside of the `Component`

type family. We can look at its definition:

```
type family Component (s :: StorageType)
(c :: ComponentType)
(a :: *) :: * where
Component 'FieldOf c a = Maybe a
Component 'SetterOf c a = Update a
Component 'WorldOf 'Field a = IntMap a
Component 'WorldOf 'Unique a = Maybe (Int, a)
```

This `Component`

thing spits out different types depending on if you want a record for the entity (`'FieldOf`

), an updater to change which components an entity has (`'SetterOf`

), or the actual universe container to hold all of this stuff (`'WorldOf`

). If we're building an entity record, every component is a `Maybe`

. If we're describing a change to an entity, we use `data Update a = Set a | Unset | Keep`

. If we want a place to store all of our entities, we generate an `IntMap`

for every `'Field`

. There's also support for adding components that are uniquely owned by a single entity, but we won't get into that today.

The trick here is that we get the user to fill in the `c :: ComponentType`

when they define the components, and ask them to keep the `s :: StorageType`

polymorphic. The library then can instantiate your `EntWorld f`

with different `StorageType`

s in order to pull out the necessary types for actually plumbing everything together.

We use the `Generic`

derivation on `EntWorld`

in order to allow ourselves to construct the underlying machinery. For example, when you're defining an entity, you don't want to be able to `Keep`

the old value of its components, since it didn't have any to begin with. We can use our `Generic`

constraint in order to generate a function `toSetter :: EntWorld 'FieldOf -> EntWorld 'SetterOf`

which takes an entity record and turns it into an entity update request, so that we don't actually need special logic to construct things. The `Generic`

constraint also helps generate default values of the `EntWorld 'WorldOf`

and other things, so that you don't need to write out any boilerplate at the value level in order to use these things.

The actual how-to-do of the `GHC.Generics`

is outside of the scope of today's post, but you can read through the source code if you're curious.

I want to make an old school point-and-click adventure game in the style of Monkey Island or Full Throttle. I've wanted to make one for as long as I can remember, and I finally have a concept and some amount of script that I think would be fitting for the medium. I spent roughly two days searching for engines to run this baby on, and I didn't have any luck whatsoever.

- adventure - an old adventure game engine I wrote back in '12 or so. It requires writing a
*lot*of lua, and appears to have bitrotten since then. I couldn't get it to compile. - Adventure Game Studio - the latest version of the IDE immediately segfaults when run through WINE.
- WinterMute - has a "garbage" rating on WINE HQ.
- Godot/Escoria - Escoria doesn't appear to run on recent versions of Godot.
- Visionaire - I successfully got the editor running on WINE, but it couldn't draw anything, so I could edit everything but had no visual feedback on anything.
- Bladecoder Adventure Engine - I fought to compile this for a while, and eventually succeeded, but got scared of it. It's written by a single guy in a language I never want to touch, and decided the risk factor was too high.
- Unity Adventure Creator - looks promising, but required forking out 70 euros before you could try it. As someone who is unemployed knows nothing about Unity, this is a pretty steep price to determine whether or not the project will work for my purposes.

So it looks like we're SOL. The existing engines don't seem like they're going to cut it. Which means we're going to need to roll our own.

Fortunately I've rolled a few of my own already. This wasn't my first rodeo. There's the previously mentioned adventure, an unnamed XNA/C# one I wrote before knowing about source control which is unfortunately lost to the sands of time, and one I most recently put together as a technical demo for a project a friend and I were going to work on. The friend pulled out, unfortunately, so the project died, but that means I have a starting point.

The engine as it existed had basic functionality for pathing around a bitmap, moving between rooms, and basic support for interacting with the environment. Unwisely, it was also a testbed for lots of type-trickery involving existentially pushing around types to manage the internal state of things in the game. It was intended that we'd do all of our game scripting directly in Haskell, and this seemed like the only approach to have that work.

So my first order of business was to tear out all of the existential stuff. I've learned since that you should always avoid existentializing things unless you are really really sure you know what you're doing. It's a soft and slow rule, but more often than not I regret existentializing things. The new plan was to script the game with a dedicating scripting language, and so Haskell never needs to know about any of the internal state.

Since writing the first draft of this game engine, I've published a library called `ecstasy`

. It's an entity-component system that allows you to describe behaviors over components of things, and then compose all of those behaviors together. The magic here is that you can write a function that only manipulates the components you need, and the library will lift it over all entities such a behavior would be relevant to. This means you can pick-and-choose different behaviors for game objects without needing to do a lot of heavy plumbing to get everything to play nicely with one another.

And so the next step was to hook up `ecstasy`

to my existing engine. I didn't want to alter any of the game's behavior yet, so entities managed by `ecstasy`

would have to exist completely parallel to the ones managed by the existing engine.

I defined my `ecstasy`

component type with the most minimal support for drawing things on the screen.

```
data EntWorld f = Entity
{ pos :: Component f 'Field Pos
, gfx :: Component f 'Field Picture
} deriving (Generic)
```

and then updated my drawing routine to find any `Entity`

who had both a `pos`

and a `gfx`

and then hook it into the existing drawing stuff:

```
drawGame :: MyState -> IO Picture
drawGame ms@(s, _) = evalGame' ms $ do
gfxs <- efor . const $
(,) <$> get pos <*> get gfx
pure . scaleToView s
. uncurry translate (-camera)
. pictures
$ roomPic
: [ drawActors actors
, drawGfxs gfxs
]
```

There was some silly plumbing necessary to connect my old, convoluted `Game`

monad with the `System`

monad provided by `ecstasy`

. That's what this `ms@(s, _)`

and `Game'`

silliness is here; little shims that can run the two monads simultaneously and reconcile the results. It was pretty gnarly, but thankfully only a hack until I could convert enough of the game logic over to being exclusively managed by `ecstasy`

.

I think that's where we'll leave the dev blog for today. I want to get us roughly caught up to the present in terms of getting from there-to-here in order to provide a better overall view of what game development in Haskell looks like. But I'm also pretty anxious to actually get some work done, rather than just describing work I have done. I expect the posts to get more technical as we get closer to being caught up, when I don't need to depend on my memory for what changes were made.

Next time we'll discuss ripping out most of the silly global variables that used to be in play, and talk about how an ECS better models things like "what should the camera be focused on?" and "how should characters navigate the space?"

Until then.

]]>For example, consider the equation:

(*x* + *y*)(*x* − *y*)=*x*^{2} − *y*^{2}

This is known as the *difference of squares*. Let's work through the derivation of it together:

$$
\begin{align*}
(x + y)(x - y) &= (x + y)(x - y) \\
&= x^2 + xy - xy - y^2 \\
&= x^2 + \cancel{xy - xy} - y^2 \\
&= x^2 - y^2
\end{align*}
$$

Recall that we can use the FOIL method to get from the first line to the second.

I implore you to read through this proof carefully, and convince yourself of its truthfulness -- even if you don't consider yourself a "math" person. Believe it or not, there's a point I'm getting to.

Anyway -- by all accounts, this difference of squares thing is a pretty humdrum theorem. Who really cares, right? Let's switch gears for a bit and talk about something more interesting.

Recall that 20 × 20 = 400. As an interesting question, without actually computing it, let's think about the product 19 × 21. What does this equal? It seems like it *could* also be 400 -- after all, all we did was take one away from the left side of the times and move it to the right.

In fact, if you work it out, 19 × 21 = 399. That's kind of interesting: somehow we lost a 1 by shuffling around the things we were multiplying.

This seems to not be an isolated incident:

$$
\begin{align*}
5 \times 5 &= 25 \\
\text{but,}\quad4 \times 6 &= 24
\end{align*}
$$

$$
\begin{align*}
10 \times 10 &= 100 \\
\text{but,}\quad9 \times 11 &= 99
\end{align*}
$$

An intriguing question to ask yourself is whether this is always true, or whether we've just gotten lucky with the examples we looked at.

But the more interesting question, in my opinion, is what happens if we go from 19 × 21 = 399 to 18 × 22. Will we lose another 1 when we fiddle with it? Or will something else happen? Form an opinion on what the answer will be before continuing.

$$
\begin{align*}
20 \times 20 &= 400 \\
\text{but,}\quad 21 \times 19 &= 399 \\
\text{but,}\quad 22 \times 18 &= 396
\end{align*}
$$

Weird -- somehow we lost 3 that time. What's happened here?

If you're confused (and I was, when I first saw this), don't despair. As it happens, you already know the answer!

So, what's going on here? Well, we've actually just been dealing with differences of squares the whole time -- probably without even realizing it!

Most people, I think, fail to connect the algebraic fact that (*x* + *y*)(*x* − *y*)=*x*^{2} − *y*^{2} to the fact that 22 × 18 = 396. If you still don't see why, we can explicitly fill in our variables:

$$
\begin{align*}
22\times18&=(20+2)(20-2)\\
&=20^2-2^2 \\
&= 400 - 4 \\
&= 396
\end{align*}
$$

Neat, right? Even if you carefully read through the proof of the difference of squares earlier, you might not have noticed that we've been playing with them the entire time! I blame western math education for this; too often are equations presented only to be *solved*, and never to be *thought about*. It's a disservice we've done to ourselves.

The takeaway of all of this, in my opinion, is that we should spend some time thinking about the notion of equality, about the = symbol. Ever since looking at this difference of squares thing, I've started viewing = not as the symbol which separates the left side of an equation from the right, but as a *transformation*. The = sign transforms something we can experience into something we can manipulate, and back again.

What I mean by that is that it's a lot easier to conceptualize 22 × 18 than it is to think about (*x* + *y*)(*x* − *y*). The numeric representation is better suited for human minds to experience, while the algebraic expression is better at twiddling. We know how to twiddle algebra, but twiddling numbers themselves is rather meaningless.

In terms of everyday usefulness, this isn't particularly helpful, except that it's often easier to compute a difference of squares than it is to do the multiplication naively. If you can recognize one, you could probably impress someone with your mental arithmetic -- but, again, it's not going to revolutionize your life in any way.

All of this is to say that math is neat. Even if you don't see any practical value in this stuff, hopefully you'll agree that there might be interesting puzzles to be found here. And, as it turns out, algebra can be a satisfying tool for solving these puzzles.

Thanks to Matt Parsons for proof-reading an early version of this post.

]]>aka "Type-Level Icing Sugar"

At work recently I've been working on a library to get idiomatic gRPC support in our Haskell project. I'm quite proud of how it's come out, and thought it'd make a good topic for a blog post. The approach demonstrates several type-level techniques that in my opinion are under-documented and exceptionally useful in using the type-system to enforce external contracts.

Thankfully the networking side of the library had already been done for me by Awake Security, but the interface feels like a thin-wrapper on top of C bindings. I'm *very, very* grateful that it exists, but I wouldn't expect myself to be able to use it in anger without causing an uncaught type error somewhere along the line. I'm sure I'm probably just using it wrong, but the library's higher-level bindings all seemed to be targeted at Awake's implementation of protobuffers.

We wanted a version that would play nicely with proto-lens, which, at time of writing, has no official support for describing RPC services via protobuffers. If you're not familiar with proto-lens, it generates Haskell modules containing idiomatic types and lenses for protobuffers, and can be used directly in the build chain.

So the task was to add support to proto-lens for generating interfaces to RPC services defined in protobuffers.

My first approach was to generate the dumbest possible thing that could work -- the idea was to generate records containing fields of the shape `Request -> IO Response`

. Of course, with a network involved there is a non-negligible chance of things going wrong, so this interface should expose some means of dealing with errors. However, the protobuffer spec is agnostic about the actual RPC backend used, and so it wasn't clear how to continue without assuming anything about the particulars behind errors.

More worrisome, however, was that RPCs can be marked as streaming -- on the side of the client, server, or both. This means, for example, that a method marked as server-streaming has a different interface on either side of the network:

```
serverSide :: Request -> (Response -> IO ()) -> IO ()
clientSide :: Request -> (IO (Maybe Response) -> IO r) -> IO r
```

This is problematic. Should we generate different records corresponding to which side of the network we're dealing with? An early approach I had was to parameterize the same record based on which side of the network, and use a type family to get the correct signature:

```
{-# LANGUAGE DataKinds #-}
data NetworkSide = Client | Server
data MyService side = MyService
{ runServerStreaming :: ServerStreamingType side Request Response
}
type family ServerStreamingType (side :: NetworkSide) input output where
ServerStreamingType Server input output =
input -> (output -> IO ()) -> IO ()
ServerStreamingType Client input output =
forall r. input -> (IO (Maybe output) -> IO r) -> IO r
```

This seems like it would work, but in fact the existence of the `forall`

on the client-side is "illegally polymorphic" in GHC's eyes, and it will refuse to compile such a thing. Giving it up would mean we wouldn't be able to return arbitrarily-computed values on the client-side while streaming data from the server. Users of the library might be able to get around it by invoking `IORef`

s or something, but it would be ugly and non-idiomatic.

So that, along with wanting to be backend-agnostic, made this approach a no-go. Luckily, my brilliant coworker Judah Jacobson (who is coincidentally also the author of proto-lens), suggested we instead generate metadata for RPC services in proto-lens, and let backend library code figure it out from there.

With all of that context out of the way, we're ready to get into the actual meat of the post. Finally.

According to the spec, a protobuffer service may contain zero or more RPC methods. Each method has a request and response type, either of which might be marked as streaming.

While we could represent this metadata at the term-level, that won't do us any favors in terms of getting type-safe bindings to this stuff. And so, we instead turn to `TypeFamilies`

, `DataKinds`

and `GHC.TypeLits`

.

For reasons that will become clear later, we chose to represent RPC services via types, and methods in those services as symbols (type-level strings). The relevant typeclasses look like this:

```
class Service s where
type ServiceName s :: Symbol
class HasMethod s (m :: Symbol) where
type MethodInput s m :: *
type MethodOutput s m :: *
type IsClientStreaming s m :: Bool
type IsServerStreaming s m :: Bool
```

For example, the instances generated for the RPC service:

```
service MyService {
rpc BiDiStreaming(stream Request) returns(stream Response);
}
```

would look like this:

```
data MyService = MyService
instance Service MyService where
type ServiceName MyService = "myService"
instance HasMethod MyService "biDiStreaming" where
type MethodInput MyService "biDiStreaming" = Request
type MethodOutput MyService "biDiStreaming" = Response
type IsClientStreaming MyService "biDiStreaming" = 'True
type IsServerStreaming MyService "biDiStreaming" = 'True
```

You'll notice that these typeclasses perfectly encode all of the information we had in the protobuffer definition. The idea is that with all of this metadata available to them, specific backends can generate type-safe interfaces to these RPCs. We'll walk through the implementation of the gRPC bindings together.

The client side of things is relatively easy. We can the `HasMethod`

instance directly:

```
runNonStreamingClient
:: HasMethod s m
=> s
-> Proxy m
-> MethodInput s m
-> IO (Either GRPCError (MethodOutput s m))
runNonStreamingClient = -- call the underlying gRPC code
runServerStreamingClient
:: HasMethod s m
=> s
-> Proxy m
-> MethodInput s m
-> (IO (Either GRPCError (Maybe (MethodOutput s m)) -> IO r)
-> IO r
runServerStreamingClient = -- call the underlying gRPC code
-- etc
```

This is a great start! We've got the interface we wanted for the server-streaming code, and our functions are smart enough to require the correct request and response types.

However, there's already some type-unsafety here; namely that nothing stops us from calling `runNonStreamingClient`

on a streaming method, or other such silly things.

Thankfully the fix is quite easy -- we can use type-level equality to force callers to be attentive to the streaming-ness of the method:

```
runNonStreamingClient
:: ( HasMethod s m
, IsClientStreaming s m ~ 'False
, IsServerStreaming s m ~ 'False
)
=> s
-> Proxy m
-> MethodInput s m
-> IO (Either GRPCError (MethodOutput s m))
runServerStreamingClient
:: ( HasMethod s m
, IsClientStreaming s m ~ 'False
, IsServerStreaming s m ~ 'True
)
=> s
-> Proxy m
-> MethodInput s m
-> (IO (Either GRPCError (Maybe (MethodOutput s m)) -> IO r)
-> IO r
-- et al.
```

Would-be callers attempting to use the wrong function for their method will now be warded off by the type-system, due to the equality constraints being unable to be discharged. Success!

The actual usability of this code leaves much to be desired (it requires being passed a proxy, and the type errors are absolutely *disgusting*), but we'll circle back on improving it later. As it stands, this code is type-safe, and that's good enough for us for the time being.

Prepare yourself (but don't panic!): the server side of things is significantly more involved.

In order to run a server, we're going to need to be able to handle any sort of request that can be thrown at us. That means we'll need an arbitrary number of handlers, depending on the service in question. An obvious thought would be to generate a record we could consume that would contain handlers for every method, but there's no obvious place to generate such a thing. Recall: proto-lens can't, since such a type would be backend-specific, and so our only other strategy down this path would be Template Haskell. Yuck.

Instead, recall that we have an instance of `HasMethod`

for every method on `Service s`

-- maybe we could exploit that information somehow? Unfortunately, without Template Haskell, there's no way to discover typeclass instances.

But that doesn't mean we're stumped. Remember that we control the code generation, and so if the representation we have isn't powerful enough, we can change it. And indeed, the representation we have isn't quite enough. We can go from a `HasMethod s m`

to its `Service s`

, but not the other way. So let's change that.

We change the `Service`

class slightly:

```
class Service s where
type ServiceName s :: Symbol
type ServiceMethods s :: [Symbol]
```

If we ensure that the `ServiceMethods s`

type family always contains an element for every instance of `HasService`

, we'll be able to use that info to discover our instances. For example, our previous `MyService`

will now get generated thusly:

```
data MyService = MyService
instance Service MyService where
type ServiceName MyService = "myService"
type ServiceMethods MyService = '["biDiStreaming"]
instance HasMethod MyService "biDiStreaming" where
type MethodInput MyService "biDiStreaming" = Request
type MethodOutput MyService "biDiStreaming" = Response
type IsClientStreaming MyService "biDiStreaming" = 'True
type IsServerStreaming MyService "biDiStreaming" = 'True
```

and we would likewise add the `m`

for any other `HasMethod MyService m`

instances if they existed.

This seems like we can now use `ServiceMethods s`

to get a list of methods, and then somehow type-level `map`

over them to get the `HasMethod s m`

constraints we want.

And we almost can, except that we haven't told the type-system that `ServiceMethods s`

relates to `HasService s m`

instances in this way. We can add a superclass constraint to `Service`

to do this:

```
class HasAllMethods s (ServiceMethods s) => Service s where
-- as before
```

But was is this `HasAllMethods`

thing? It's a specialized type-level `map`

which turns our list of methods into a bunch of constraints proving we have `HasMethod s m`

for every `m`

in that promoted list.

```
class HasAllMethods s (xs :: [Symbol])
instance HasAllMethods s '[]
instance (HasMethod s x, HasAllMethods s xs) => HasAllMethods s (x ': xs)
```

We can think of `xs`

here as the list of constraints we want. Obviously if we don't want any constraints (the `'[]`

case), we trivially have all of them. The other case is induction: if we have a non-empty list of constraints we're looking for, that's the same as looking for the tail of the list, and having the constraint for the head of it.

Read through these instances a few times; make sure you understand the approach before continuing, because we're going to keep using this technique in scarier and scarier ways.

With this `HasAllMethods`

superclass constraint, we can now convince ourselves (and, more importantly, GHC), that we can go from a `Service s`

constraint to all of its `HasMethod s m`

constraints. Cool!

We return to thinking about how to actually run a server. As we've discussed, such a function will need to be able to handle every possible method, and, unfortunately, we can't pack them into a convenient data structure.

Our actual implementation of such a thing might take a list of handlers. But recall that each handler has different input and output types, as well as different shapes depending on which bits of it are streaming. We can make this approach work by existentializing away all of the details.

While it works as far as the actual implementation of the underlying gRPC goes, we're left with a great sense of uneasiness. We have no guarantees that we've provided a handler for every method, and the very nature of existentialization means we have absolutely no guarantees that any of these things are the right ype.

Our only recourse is to somehow use our `Service s`

constraint to put a prettier facade in front of this ugly-if-necessary implementation detail.

The actual interface we'll eventually provide will, for example, for a service with two methods, look like this:

`runServer :: HandlerForMethod1 -> HandlerForMethod2 -> IO ()`

Of course, we can't know a priori how many methods there will be (or what type their handlers should have, for that matter). We'll somehow need to extract this information from `Service s`

-- which is why we previously spent so much effort on making the methods discoverable.

The technique we'll use is the same one you'll find yourself using again and again when you're programming at the type-level. We'll make a typeclass with an associated type family, and then provide a base case and an induction case.

```
class HasServer s (xs :: [Symbol]) where
type ServerType s xs :: *
```

We need to make the methods `xs`

explicit as parameters in the typeclass, so that we can reduce them. The base case is simple -- a server with no more handlers is just an IO action:

```
instance HasServer s '[] where
type ServerType s '[] = IO ()
```

The induction case, however, is much more interesting:

```
instance ( HasMethod s x
, HasMethodHandler s x
, HasServer s xs
) => HasServer s (x ': xs) where
type ServerType s (x ': xs) = MethodHandler s x -> ServerType s xs
```

The idea is that as we pull methods `x`

off our list of methods to handle, we build a function type that takes a value of the correct type to handle method `x`

, which will take another method off the list until we're out of methods to handle. This is exactly a type-level fold over a list.

The only remaining question is "what is this `MethodHandler`

thing?" It's going to have to be a type family that will give us back the correct type for the handler under consideration. Such a type will need to dispatch on the streaming variety as well as the request and response, so we'll define it as follows, and go back and fix `HasServer`

later.

```
class HasMethodHandler input output cs ss where
type MethodHandler input output cs ss :: *
```

`cs`

and `ss`

refer to whether we're looking for client-streaming and/or server-streaming types, respectively.

Such a thing could be a type family, but isn't because we'll need its class-ness later in order to actually provide an implementation of all of this stuff. We provide the following instances:

```
-- non-streaming
instance HasMethodHandler input output 'False 'False where
type MethodHandler input output 'False 'False =
input -> IO output
-- server-streaming
instance HasMethodHandler input output 'False 'False where
type MethodHandler input output 'False 'True =
input -> (output -> IO ()) -> IO ()
-- etc for client and bidi streaming
```

With `MethodHandler`

now powerful enough to give us the types we want for handlers, we can go back and fix `HasServer`

so it will compile again:

```
instance ( HasMethod s x
, HasMethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
, HasServer s xs
) => HasServer s (x ': xs) where
type ServerType s (x ': xs)
= MethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
-> ServerType s xs
```

It's not pretty, but it works! We can convince ourselves of this by asking ghci:

```
ghci> :kind! ServerType MyService (ServiceMethods MyService)
(Request -> (Response -> IO ()) -> IO ()) -> IO () :: *
```

and, if we had other methods defined for `MyService`

, they'd show up here with the correct handler type, in the order they were listed in `ServiceMethods MyService`

.

Our `ServerType`

family now expands to a function type which takes a handler value (of the correct type) for every method on our service. That turns out to be more than half the battle -- all we need to do now is to provide a value of this type.

The generation of such a value is going to need to proceed in perfect lockstep with the generation of its type, so we add to the definition of `HasServer`

:

```
class HasServer s (xs :: [Symbol]) where
type ServerType s xs :: *
runServerImpl :: [AnyHandler] -> ServerType s xs
```

What is this `[AnyHandler]`

thing, you might ask. It's an explicit accumulator for existentialized handlers we've collected during the fold over `xs`

. It'll make sense when we look at the induction case.

For now, however, the base case is trivial as always:

```
instance HasServer s '[] where
type ServerType s '[] = IO ()
runServerImpl handlers = runGRPCServer handlers
```

where `runGRPCServer`

is the underlying server provided by Awake's library.

We move to the induction case:

```
instance ( HasMethod s x
, HasMethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
, HasServer s xs
) => HasServer s (x ': xs) where
type ServerType s (x ': xs)
= MethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
-> ServerType s xs
runServerImpl handlers f = runServerImpl (existentialize f : handlers)
```

where `existentialize`

is a new class method we add to `HasMethodHandler`

We will elide it here because it is just a function `MethodHandler i o cs mm -> AnyHandler`

and is not particularly interesting if you're familiar with existentialization.

It's evident here what I meant by `handlers`

being an explicit accumulator -- our recursion adds the parameters it receives into this list so that it can pass them eventually to the base case.

There's a problem here, however. Reading through this implementation of `runServerImpl`

, you and I both know what the right-hand-side means, unfortunately GHC isn't as clever as we are. If you try to compile it right now, GHC will complain about the non-injectivity of `HasServer`

as implied by the call to `runServerImpl`

(and also about `HasMethodHandler`

and `existentialize`

, but for the exact same reason.)

The problem is that there's nothing constraining the type variables `s`

and `xs`

on `runServerImpl`

. I always find this error confusing (and I suspect everyone does), because in my mind it's perfectly clear from the `HasServer s xs`

in the instance constraint. However, because `SeverType`

is a type family without any injectivity declarations, it means we can't learn `s`

and `xs`

from `ServerType s xs`

.

Let's see why. For a very simple example, let's look at the following type family:

```
type family NotInjective a where
NotInjective Int = ()
NotInjective Bool = ()
```

Here we have `NotInjective Int ~ ()`

and `NotInjective Bool ~ ()`

, which means even if we know `NotInjective a ~ ()`

it doesn't mean that we know what `a`

is -- it could be either `Int`

or `Bool`

.

This is the exact problem we have with `runServerImpl`

: even though we know what type `runServerImpl`

has (it must be `ServerType s xs`

, so that the type on the left-hand of the equality is the same as on the right), that doesn't mean we know what `s`

and `xs`

are! The solution is to explicitly tell GHC via a type signature or type application:

```
instance ( HasMethod s x
, HasMethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
, HasServer s xs
) => HasServer s (x ': xs) where
type ServerType s (x ': xs)
= MethodHandler (MethodInput s x)
(MethodOutput s x)
(IsClientStreaming s x)
(IsServerStreaming s x)
-> ServerType s xs
runServerImpl handlers f = runServerImpl @s @xs (existentialize f : handlers)
```

(For those of you playing along at home, you'll need to type-apply the monstrous `MethodInput`

and friends to the `existentialize`

as well.)

And finally, we're done! We can slap a prettier interface in front of this `runServerImpl`

to fill in some of the implementation details for us:

```
runServer
:: forall s
. ( Service s
, HasServer s (ServiceMethods s)
)
=> s
-> ServerType s (ServiceMethods s)
runServer _ = runServerImpl @s @(ServiceMethods s) []
```

Sweet and typesafe! Yes!

Sweet and typesafe all of this might be, but the user-friendliness on the client-side leaves a lot to be desired. As promised, we'll address that now.

Recall that the `runNonStreamingClient`

function and its friends require a `Proxy m`

parameter in order to specify the method you want to call. However, `m`

has kind `Symbol`

, and thankfully we have some new extensions in GHC for turning `Symbol`

s into values.

We can define a new type, isomorphic to `Proxy`

, but which packs the fact that it is a `KnownSymbol`

(something we can turn into a `String`

at runtime):

```
data WrappedMethod (sym :: Symbol) where
WrappedMethod :: KnownSymbol sym => WrappedMethod sym
```

We change our `run*Client`

friends to take this `WrappedMethod m`

instead of the `Proxy m`

they used to:

```
runNonStreamingClient
:: ( HasMethod s m
, IsClientStreaming s m ~ 'False
, IsServerStreaming s m ~ 'False
)
=> s
-> WrappedMethod m
-> MethodInput s m
-> IO (Either GRPCError (MethodOutput s m))
```

and, with this change in place, we're ready for the magic syntax I promised earlier.

```
import GHC.OverloadedLabel
instance ( KnownSymbol sym
, sym ~ sym'
) => IsLabel sym (WrappedMethod sym') where
fromLabel _ = WrappedMethod
```

This `sym ~ sym'`

thing is known as the constraint trick for instances, and is necessary here to convince GHC that this can be the only possible instance of `IsLabel`

that will give you back `WrappedMethod`

s.

Now turning on the `{-# LANGUAGE OverloadedLabels #-}`

pragma, we've changed the syntax to call these client functions from the ugly:

`runBiDiStreamingClient MyService (Proxy @"biDiStreaming")`

into the much nicer:

`runBiDiStreamingClient MyService #biDiStreaming`

The next step in our journey to delightful usability is remembering that the users of our library are only human, and at some point they are going to call the wrong `run*Client`

function on their method with a different variety of streaming semantics.

At the moment, the errors they're going to get when they try that will be a few stanza long, the most informative of which will be something along the lines of `unable to match 'False with 'True`

. Yes, it's technically correct, but it's entirely useless.

Instead, we can use the `TypeError`

machinery from `GHC.TypeLits`

to make these error messages actually helpful to our users. If you aren't familiar with it, if GHC ever encounters a `TypeError`

constraint it will die with a error message of your choosing.

We will introduce the following type family:

```
type family RunNonStreamingClient (cs :: Bool) (ss :: Bool) :: Constraint where
RunNonStreamingClient 'False 'False = ()
RunNonStreamingClient 'False 'True = TypeError
( Text "Called 'runNonStreamingClient' on a server-streaming method."
:$$: Text "Perhaps you meant 'runServerStreamingClient'."
)
RunNonStreamingClient 'True 'False = TypeError
( Text "Called 'runNonStreamingClient' on a client-streaming method."
:$$: Text "Perhaps you meant 'runClientStreamingClient'."
)
RunNonStreamingClient 'True 'True = TypeError
( Text "Called 'runNonStreamingClient' on a bidi-streaming method."
:$$: Text "Perhaps you meant 'runBiDiStreamingClient'."
)
```

The `:$$:`

type operator stacks message vertically, while `:<>:`

stacks it horizontally.

We can change the constraints on `runNonStreamingClient`

:

```
runNonStreamingClient
:: ( HasMethod s m
, RunNonStreamingClient (IsClientStreaming s m)
(IsServerStreaming s m)
)
=> s
-> WrappedMethod m
-> MethodInput s m
-> IO (Either GRPCError (MethodOutput s m))
```

and similarly for our other client functions. Reduction of the resulting boilerplate is left as an exercise to the reader.

With all of this work out of the way, we can test it:

`runNonStreamingClient MyService #biDiStreaming`

```
Main.hs:45:13: error:
• Called 'runNonStreamingClient' on a bidi-streaming method.
Perhaps you meant 'runBiDiStreamingClient'.
• In the expression: runNonStreamingClient MyService #bidi
```

Amazing!

The other class of errors we expect our users to make is to attempt to call a method that doesn't exist -- either because they made a typo, or are forgetful of which methods exist on the service in question.

As it stands, users are likely to get about six stanzas of error messages, from `No instance for (HasMethod s m)`

to `Ambiguous type variable 'm0'`

, and other terrible things that leak our implementation details. Our first thought might be to somehow emit a `TypeError`

constraint if we *don't* have a `HasMethod s m`

instance, but I'm not convinced such a thing is possible.

But luckily, we can actually do better than any error messages we could produce in that way. Since our service is driven by a value (in our example, the data constructor `MyService`

), by the time things go wrong we *do* have a `Service s`

instance in scope. Which means we can look up our `ServiceMethods s`

and given some helpful suggestions about what the user probably meant.

The first step is to implement a `ListContains`

type family so we can determine if the method we're looking for is actually a real method.

```
type family ListContains (n :: k) (hs :: [k]) :: Bool where
ListContains n '[] = 'False
ListContains n (n ': hs) = 'True
ListContains n (x ': hs) = ListContains n hs
```

In the base case, we have no list to look through, so our needle is trivially not in the haystack. If the head of the list is the thing we're looking for, then it must be in the list. Otherwise, take off the head of the list and continue looking. Simple really, right?

We can now use this thing to generate an error message in the case that the method we're looking for is not in our list of methods:

```
type family RequireHasMethod s (m :: Symbol) (found :: Bool) :: Constraint where
RequireHasMethod s m 'False = TypeError
( Text "No method "
:<>: ShowType m
:<>: Text " available for service '"
:<>: ShowType s
:<>: Text "'."
:$$: Text "Available methods are: "
:<>: ShowType (ServiceMethods s)
)
RequireHasMethod s m 'True = ()
```

If `found ~ 'False`

, then the method `m`

we're looking for is not part of the service `s`

. We produce a nice error message informing the user about this (using `ShowType`

to expand the type variables).

We will provide a type alias to perform this lookup:

```
type HasMethod' s m =
( RequireHasMethod s m (ListContains m (ServiceMethods s)
, HasMethod s m
)
```

Our new `HasMethod' s m`

has the same shape as `HasMethod`

, but will expand to our custom type error if we're missing the method under scrutiny.

Replacing all of our old `HasMethod`

constraints with `HasMethod'`

works fantastically:

```
Main.hs:54:15: error:
• No method "missing" available for service 'MyService'.
Available methods are: '["biDiStreaming"]
```

Damn near perfect! That list of methods is kind of ugly, though, so we can write a quick pretty printer for showing promoted lists:

```
type family ShowList (ls :: [k]) :: ErrorMessage where
ShowList '[] = Text ""
ShowList '[x] = ShowType x
ShowList (x ': xs) = ShowType x :<>: Text ", " :<>: ShowList xs
```

Replacing our final `ShowType`

with `ShowList`

in `RequireHasMethod`

now gives us error messages of the following:

```
Main.hs:54:15: error:
• No method "missing" available for service 'MyService'.
Available methods are: "biDiStreaming"
```

Absolutely gorgeous.

This is where we stop. We've used type-level metadata to generate client- and server-side bindings to an underlying library. Everything we've made is entirely typesafe, and provides gorgeous, helpful error messages if the user does anything wrong. We've found a practical use for many of these seemingly-obscure type-level features, and learned a few things in the process.

In the words of my coworker Renzo Carbonara^{1}:

"It is up to us, as people who understand a problem at hand, to try and teach the type system as much as we can about that problem. And when we don’t understand the problem, talking to the type system about it will help us understand. Remember, the type system is not magic, it is a logical reasoning tool."

This resounds so strongly in my soul, and maybe it will in yours too. If so, I encourage you to go forth and find uses for these techniques to improve the experience and safety of your own libraries.

Whose article "Opaleye's sugar on top" was a strong inspiration on me, and subsequently on this post.↩