## Sunday, December 31, 2017

### N-ary Functors

update: Now available on hackage as `n-ary-functor`.

`Functor` and `Bifunctor` are both in `base`, but what about `Trifunctor`? `Quadrifunctor`? There must be a better solution than creating an infinite tower of typeclasses. Here's the API I managed to implement:

``````> nmap <#> (+1) <#> (+2) \$ (0, 0)
(1,2)

> nmap <#> (+1) <#> (+2) <#> (+3) \$ (0, 0, 0)
(1,2,3)

> nmap <#> (+1) <#> (+2) <#> (+3) <#> (+4) \$ (0, 0, 0, 0)
(1,2,3,4)``````

The implementation is really short, too:

``````{-# LANGUAGE RankNTypes, TypeFamilies, TypeInType #-}
import Data.Kind

newtype NMap1 k (f :: Type -> k) (g :: Type -> k) = NMap1
{ (<#>) :: forall a b. (a -> b) -> NMap k (f a) (g b) }

type family NMap k :: k -> k -> Type where
NMap Type        = (->)
NMap (Type -> k) = NMap1 k

class NFunctor (f :: k) where
nmap :: NMap k f f``````

Of course, the hard part is not writing the code, but figuring out what to write down. Let me show you how I got there.

#### Computing the Type from the Kind

Since `Functor` instances are given to type constructors of kind `* -> *`, and `Bifunctor` instances are given to type constructors of kind `* -> * -> *`, my idea was to compute the type of `nmap` from the kind of the type constructor to which it is applied. Something like this:

``````class NFunctor (f :: k) where
nmap :: NMap k f

type family NMap k (f :: k) :: *
type instance NMap (* -> *) f
= (a -> b) -> f a -> f b
type instance NMap (* -> * -> *) f
= (a1 -> b1) -> (a2 -> b2) -> f a1 a2 -> f b1 b2
type instance NMap (* -> * -> * -> *) f
= (a1 -> b1) -> (a2 -> b2) -> (a3 -> b3) -> f a1 a2 a3 -> f b1 b2 b3``````

Except of course with some recursive definition for `NMap`, so we don't have to spell out the type for every kind. Thinking of it in terms of recursion made me realize that the base case is kind `*`, not `* -> *`:

``````type instance NMap * f
= f -> f``````

This corresponds to a "nullary Functor" typeclass, whose lawful instances have no choice but to use the identity function. So this isn't particularly useful as a typeclass, but it does lead to a nice recursive definition:

``````type family NMap k (f :: k) (g :: k) where
NMap Type        a b = a -> b
NMap (Type -> k) f g = (a -> b) -> NMap k (f a) (g b)

class NFunctor (f :: k) where
nmap :: NMap k f f``````

I now have to use `Type` instead of `*` for some reason, otherwise I get a "malformed head" error.

#### Required Newtype Wrapper

Unfortunately, GHC does not accept that recursive definition. First of all, when defining a type family, type variables aren't implicitly universally-quantified like they are in type signatures, so I need to add an explicit `forall` quantifier:

``````type family NMap k (f :: k) (g :: k) where
NMap Type        a b = a -> b
NMap (Type -> k) f g = forall a b. (a -> b) -> NMap k (f a) (g b)``````

Now GHC reveals the real problem with the definition:

``````• Illegal polymorphic type:
forall a b. (a -> b) -> NMap k (f a) (g b)
• In the equations for closed type family ‘NMap’
In the type family declaration for ‘NMap’``````

This is a bummer: I am simply not allowed to use `forall` here. The usual workaround, when `forall` is needed but disallowed, is to define a newtype which performs the `forall` for us:

``````newtype NMap1 k (f :: Type -> k) (g :: Type -> k) = NMap1
{ runNMap1 :: forall a b. (a -> b) -> NMap k (f a) (g b) }

type family NMap k :: k -> k -> Type where
NMap Type        = (->)
NMap (Type -> k) = NMap1 k``````

This solves the problem, and even allows me to make my `NMap` definition more point-free!

#### Ergonomics

I now have a typeclass which generalizes `Functor`, `Bifunctor`, `Trifunctor`, etc., but what does using this typeclass look like? Writing instances requires a bit of boilerplate, but it's not too bad:

``````instance NFunctor Maybe where
nmap = NMap1 fmap

instance NFunctor (,) where
nmap = NMap1 \$ \f1
-> NMap1 \$ \f2
-> \(x1,x2)
-> (f1 x1, f2 x2)

instance NFunctor (,,) where
nmap = NMap1 \$ \f1
-> NMap1 \$ \f2
-> NMap1 \$ \f3
-> \(x1,x2,x3)
-> (f1 x1, f2 x2, f3 x3)

instance NFunctor (,,,) where
nmap = NMap1 \$ \f1
-> NMap1 \$ \f2
-> NMap1 \$ \f3
-> NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (f1 x1, f2 x2, f3 x3, f4 x4)``````

When calling `nmap`, however, the extra boilerplate quickly becomes annoying:

``````> runNMap1 nmap (+1) \$ Just (0)
Just 1

> runNMap1 (runNMap1 nmap (+1)) (+2) (0, 0)
(1,2)

> runNMap1 (runNMap1 (runNMap1 nmap (+1)) (+2)) (+3) (0, 0, 0)
(1,2,3)

> runNMap1 (runNMap1 (runNMap1 (runNMap1 nmap (+1))
|                              (+2))
|                    (+3))
|          (+4)
|          (0, 0, 0, 0)
(1,2,3,4)``````

The fix is really simple though: by renaming `runNMap1` to some left-associative infix operator, say `(<#>)`, the code becomes much more readable!

``````> nmap <#> (+1) \$ Just (0)
Just 1

> nmap <#> (+1) <#> (+2) \$ (0, 0)
(1,2)

> nmap <#> (+1) <#> (+2) <#> (+3) \$ (0, 0, 0)
(1,2,3)

> nmap <#> (+1) <#> (+2) <#> (+3) <#> (+4) \$ (0, 0, 0, 0)
(1,2,3,4)``````

#### A Tempting Overlapping Instance

Pairs have both a `Bifunctor` and a `Functor` instance. Similarly, quadruples have four `NFunctor` instances, five if we count the glorified identity function:

``````-- |
-- >>> nmap <#> (+1) <#> (+2) <#> (+3) <#> (+4) \$ (0, 0, 0, 0)
-- (1,2,3,4)
instance NFunctor (,,,) where
nmap = NMap1 \$ \f1
-> NMap1 \$ \f2
-> NMap1 \$ \f3
-> NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (f1 x1, f2 x2, f3 x3, f4 x4)

-- |
-- >>> nmap <#> (+1) <#> (+2) <#> (+3) \$ (0, 0, 0, 0)
-- (0,1,2,3)
instance NFunctor ((,,,) a) where
nmap = NMap1 \$ \f2
-> NMap1 \$ \f3
-> NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (x1, f2 x2, f3 x3, f4 x4)

-- |
-- >>> nmap <#> (+1) <#> (+2) \$ (0, 0, 0, 0)
-- (0,0,1,2)
instance NFunctor ((,,,) a b) where
nmap = NMap1 \$ \f3
-> NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (x1, x2, f3 x3, f4 x4)

-- |
-- >>> nmap <#> (+1) \$ (0, 0, 0, 0)
-- (0,0,0,1)
instance NFunctor ((,,,) a b c) where
nmap = NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (x1, x2, x3, f4 x4)

-- |
-- >>> nmap (0, 0, 0, 0)
-- (0,0,0,0)
instance NFunctor ((,,,) a b c d) where
nmap = \(x1,x2,x3,x4)
-> (x1, x2, x3, x4)``````

But if we define the following magical instance:

``````{-# LANGUAGE FlexibleInstances #-}

instance NFunctor (f :: * -> k) => NFunctor (f a) where
nmap = nmap <#> id``````

Then we get all five instances for the price of one!

``````-- |
-- >>> nmap <#> (+1) <#> (+2) <#> (+3) <#> (+4) \$ (0, 0, 0, 0)
-- (1,2,3,4)
-- >>> nmap <#> (+1) <#> (+2) <#> (+3) \$ (0, 0, 0, 0)
-- (0,1,2,3)
-- >>> nmap <#> (+1) <#> (+2) \$ (0, 0, 0, 0)
-- (0,0,1,2)
-- >>> nmap <#> (+1) \$ (0, 0, 0, 0)
-- (0,0,0,1)
-- >>> nmap (0, 0, 0, 0)
-- (0,0,0,0)
instance NFunctor (,,,) where
nmap = NMap1 \$ \f1
-> NMap1 \$ \f2
-> NMap1 \$ \f3
-> NMap1 \$ \f4
-> \(x1,x2,x3,x4)
-> (f1 x1, f2 x2, f3 x3, f4 x4)``````

The big problem with that magic instance is that it overlaps with other instances we would like to define. For example, we don't want to define the `NFunctor` instance for `State s` in terms of the `NFunctor` instance for `State`, because `State` is not functorial in `s`, so it doesn't have such an instance. Oh well.

## Friday, November 03, 2017

### Computing with Impossible Types

Edward Kmett recently posted a puzzling gist seemingly showing that at the type level, the `()` kind has more than one inhabitant. The goal of this post is to explain what's going on.

#### Stuck Type Expressions

Here is a simple type family.

``````{-# LANGUAGE TypeFamilies, UndecidableInstances #-}

type family F a where
F (Maybe a) = [F a]
F a         = a``````

Since `F (Maybe Int)` and `[F Int]` both evaluate to `[Int]`, the following type-checks.

``````-- |
-- >>> :kind! F (Maybe Int) -> [F Int]
-- F (Maybe Int) -> [F Int] :: *
-- = [Int] -> [Int]
runFMaybeInt :: F (Maybe Int) -> [F Int]
runFMaybeInt = id``````

We didn't use any `Int`-specific code, so let's make the type more polymorphic.

``````-- |
-- >>> :set -XRankNTypes
-- >>> :kind! forall b. F (Maybe b) -> [F b]
-- forall b. F (Maybe b) -> [F b] :: *
-- = [F b] -> [F b]
runFMaybe :: Proxy b -> F (Maybe b) -> [F b]
runFMaybe _ = id``````

Notice that `F (Maybe b)` and `[F b]` both evaluate to `[F b]`, not to `[b]`! That's because we don't yet know whether `b` is going to be instantiated with a `Maybe` something or not, so unlike `F Int`, the type expression `F b` cannot be simplified further. The evaluation of `F b` is stuck, and will remain so until we learn more information about `b`. The code still type-checks though, because even though we don't know which concrete type `F b` will expand to, we do know that `[F b]` and `[F b]` will expand to the same type because they are the same type expression.

#### Pattern-Matching on the Shape

Here is another type family.

``````type family G a where
G (f a) = [G a]
G a     = Double``````

This time, the type family isn't pattern-matching on whether or not its input type is a `Maybe` something, but on whether or not it is a type which, like `Maybe Int`, consists of a type constructor applied to a type. Let's look at a concrete example:

``````-- |
-- >>> :kind! G (Maybe Int) -> [G Int]
-- G (Maybe Int) -> [G Int] :: *
-- = [Double] -> [Double]
runGMaybeInt :: G (Maybe Int) -> [G Int]
runGMaybeInt = id``````

No surprises there. Let's make the type more polymorphic:

``````-- |
-- >>> :kind! forall g b. G (g b) -> [G b]
-- forall g b. G (g b) -> [G b] :: *
-- = [G b] -> [G b]
runGMaybe :: Proxy (g b) -> G (g b) -> [G b]
runGMaybe _ = id``````

As before, the type expression `G b` is stuck because we don't yet know whether `b` is going to be instantiated to a type with the right shape such as `Maybe Int`, or to a type with a different shape such as `Int`. But regardless of which one it is, `[G b]` and `[G b]` will both expand to the same type, so the implementation type-checks.

One last example:

``````>>> :kind! forall b. G (G b) -> [G b]
forall b. G (G b) -> [G b] :: *
= G (G b) -> [G b]``````

Note that `G (G b)` did not simplify! `G b` might look like it has the right shape to match `g b`, but it doesn't, because `G` is a type family, not a type constructor. It's a good thing it doesn't match, because if it did, evaluating type expressions like `G (G Int)` wouldn't be confluent! If we evaluate the outer application first, we get `[G Int]` and then `[Double]`, whereas if we evaluate the inner application first, we get `G Double` and then `Double`.

To be clear, evaluating the outer application first doesn't work because we don't yet know whether the type expression `G Int` will evaluate to something of the form `f a` or not. So the inner application is evaluated first, and `G (G Int)` evaluates to `Double`.

#### Two Arrow-Like Kinds

`G` and `Maybe` both seem to have kind `* -> *`:

``````>>> :kind! G
G :: * -> *
>>> :kind! Maybe
Maybe :: * -> *``````

But that's misleading, because there are some circumstances in which a type of kind `* -> *` is expected but only `Maybe` will be accepted:

``````class MyMonad (m :: * -> *)

-- ok

-- error: The type family ‘G’ should have 1 argument,
--        but has been given none

And there are other circumstances in which both `G` and `Maybe` will be accepted:

``````{-# LANGUAGE DataKinds, TypeOperators #-}

-- |
-- >>> :kind! FMap Maybe '[Int, Double]
-- FMap Maybe '[Int, Double] :: [*]
-- = '[Maybe Int, Maybe Double]
--
-- >>> :kind! FMap G '[Int, Double]
-- FMap G '[Int, Double] :: [*]
-- = '[Double, Double]
type family FMap (f :: * -> *) as where
FMap f '[]       = '[]
FMap f (a ': as) = (f a ': FMap f as)``````

So I prefer to pretend that there are two different arrow-like kind constructors:

1. `(-->)` for type functions which can be applied to a type argument. `G` and `Maybe` both have kind `* --> *`. Just like it isn't possible to pattern-match on a type variable, it is not possible to pattern-match on a type expression whose head is a `(-->)`, we must instead apply the type function and pattern-match on the result.
2. `(->)` for type constructors which can be pattern-matched on. `Maybe` has kind `* -> *`, but `G` does not. Clearly, `(->)` is a subtype of `(-->)`.

Now we can make sense of the previous examples. Instance resolution works by pattern-matching on types, so `MyMonad` expects a `* -> *`, not a `* --> *`. Since `G` has the wrong kind, it cannot be given a `MyMonad` instance. `FMap`, on the other hand, only needs to apply its `f` to various `a`s, so it expects an `* --> *` such as `G`. Since `* -> *` is a subtype of `* --> *`, `FMap` can also be applied to `Maybe`.

edit:
Apparently `:kind!` is misleading here. Outside of `:kind!`, `FMap` accepts `Maybe` but not `G`. So the situation is simpler than I thought: `(-->)` is for type families, `(->)` is for type constructors, and those are completely different arrow kinds, there is no subtyping relationship between the two. There is no way to ask for an argument of kind `* --> *`, because if we try to pass an "unsaturated" argument with that kind, `G` for example, GHC will complain that `G` is missing arguments. So `MyMonad` and `FMap` both expect an argument of kind `* -> *`, not `* --> *`.

#### Unusual Type Families

Here are a few surprising, yet legal type families.

``````-- |
-- >>> :kind! H1 ('Just '())
-- H1 ('Just '()) :: * -> *
-- = Maybe
type family H1 (a :: Maybe ()) :: * -> * where
H1 ('Just a) = Maybe
H1 'Nothing  = IO``````

`H1`'s input has kind `Maybe ()`, not `*`, and its output has kind `* -> *`, not `*`. Note that it's really `* -> *`, not `* --> *`, so `G` is not a valid output. Overall, the kind of `H1` is thus `Maybe () --> * -> *`.

``````-- |
-- >>> :kind! H2
-- H2 :: *
-- = Int
type family H2 where
H2 = Int``````

`H2` has no type parameters, so it's kind is `*`, not `* --> *`. If it returned `Maybe` instead of `Int`, its kind would be `* -> *` instead. A type family's kind can be either `* --> *` or `* -> *` depending on how it's defined, so it's not as simple as "type constructors use `(->)`, type families use `(-->)`".

Combining both ideas together:

``````type family J :: () -> Maybe () where
J = 'Just``````

`J`'s kind is `() -> Maybe ()`, so it has to return a type constructor which accepts a type of kind `()` and produces a type of kind `Maybe ()`. There are only two types which have the kind `Maybe ()`: the type `'Nothing`, and the type `'Just '()`. `'Nothing` has the wrong kind, since it doesn't accept a type of kind `()`, but `'Just` is just right.

One last complication:

``````-- |
-- >>> :kind! H3 Int
-- H3 Int :: *
-- = H3 Int
type family H3 a where``````

`H3` has no equations defining what happens when it is applied to a type argument. As a result, the type expression `H3 Int` remains stuck even though it doesn't contain any type variables.

Combining everything together:

``type family Succ :: () -> () where``

`Succ` pretends that it can produce a type constructor which accepts a type of kind `()` and produces a type of kind `()`. This is ridiculous! We know that `'()` is the only type of kind `()`, and like `'Nothing`, it has the wrong kind because it doesn't accept a type of kind `()`. There are no valid types which `Succ` could return, so unsurprisingly it has no equations, and so `Succ` is a type expression which always remains stuck.

#### Ignoring Impossible Types

The type expression `Succ '()` is stuck, but well-kinded. It has kind `()`.

That's the kind which `'Just :: () -> Maybe ()` expects. Thus, `'Just (Succ '())` is also stuck and well-kinded. It has kind `Maybe ()`.

That's the kind which our `H1 :: Maybe () --> * -> *` type family from earlier expects. Is `H1 ('Just (Succ '()))` stuck as well?

``````>>> :kind! H1 ('Just (Succ '()))
H1 ('Just (Succ '())) :: * -> *
= Maybe``````

Not stuck! That's because `H1` ignores the part which is stuck. Its pattern is `('Just a)`, so it pattern-matches on the `'Just` constructor, but it ignores its argument. If its pattern was `('Just '())` instead, it would have been stuck.

Here comes the clever part: it is possible to write a type family which pattern-matches on the `'()` but ignores the stuck `Succ` part.

``````-- |
-- >>> :kind! IsSucc (Succ '())
-- IsSucc (Succ '()) :: Bool
-- = 'True
--
-- >>> :kind! IsSucc '()
-- IsSucc '() :: Bool
-- = 'False
type family IsSucc (a :: ()) :: Bool where
IsSucc (succ '()) = 'True
IsSucc '()        = 'False``````

The trick is to do like `G` and pattern-match on the shape, not the contents.

#### Computing with Impossible Types

It is also possible to distinguish the two inhabitants using a typeclass instead of a type family:

``````{-# language FlexibleInstances #-}
import Data.Proxy

-- |
-- >>> isSucc (Proxy :: Proxy (Succ '()))
-- True
-- >>> isSucc (Proxy :: Proxy '())
-- False
class IsSucc (a :: ()) where
isSucc :: Proxy a -> Bool

instance IsSucc (succ '()) where
isSucc _ = True

instance IsSucc '() where
isSucc _ = False``````

The fact that this works is surprising, because `()` is supposed to be a closed kind with only one inhabitant, `'()`, and yet here we seemingly have a second inhabitant, `Succ '()`, which can be distinguished from `'()` even though it is stuck. And as you might surmise from its name, we can manufacture many more inhabitants: `Succ (Succ '())`, `Succ (Succ (Succ '()))`, etc.

``````{-# language ScopedTypeVariables #-}

-- |
-- >>> countSuccs (Proxy :: Proxy '())
-- 0
-- >>> countSuccs (Proxy :: Proxy (Succ '()))
-- 1
-- >>> countSuccs (Proxy :: Proxy (Succ (Succ (Succ '()))))
-- 3
class CountSuccs (a :: ()) where
countSuccs :: Proxy a -> Int

instance CountSuccs '() where
countSuccs _ = 0

instance CountSuccs a => CountSuccs (succ a) where
countSuccs _ = 1 + countSuccs (Proxy :: Proxy a)``````

Those examples show how to compute booleans and integers from a stuck type expression containing `Succ`s. Using polymorphic recursion, it is also possible to go the other way, from an integer to a stuck type expression containing that many `Succ`s:

``````{-# language RankNTypes #-}

-- |
-- >>> mkSuccs 42 countSuccs
-- 42
mkSuccs :: Int -> (forall a. CountSuccs a => Proxy a -> r) -> r
mkSuccs 0 cc = cc (Proxy :: Proxy '())
mkSuccs n cc = mkSuccs (n - 1) \$ \(Proxy :: Proxy a)
-> cc (Proxy :: Proxy (Succ a))``````

Since Haskell doesn't have dependent types, the output type is independent of the integer, so we cannot directly return the stuck type as an output. Instead, we use continuation-passing-style to accept a polymorphic continuation which produces an `r` regardless of which stuck type we instantiate it at.

When we use `countSuccs` as the continuation, this `r` is an integer, and the integer it computes is the number of `Succ`s. So we start with `n`, we convert it to a stuck type containing `n` `Succ`s, and then we count those `Succ`s and get `n` back. This is a very simple example of a computation which relies on the existence of those seemingly-impossible non-`'()` inhabitants of `()` in order to compute its result: if there was only one type of kind `()`, the integer would be lost during the conversion to `Proxy (a :: ())`, and we would not be able to get that same integer back at the end.

#### Full Circle

Now that we have seen and understood each of the pieces individually, we are now ready to marvel at Kmett's creation:

``````{-# language PolyKinds #-}

import Data.Proxy

class KnownUnit (k :: ()) where
reflect :: Proxy k -> Int

instance KnownUnit '() where
reflect _ = 0

instance KnownUnit x => KnownUnit (f x) where
reflect _ = 1 + reflect (Proxy :: Proxy x)

type family Succ :: k -> k

-- |
-- >>> reify 23 reflect
-- 23
reify :: Int -> (forall k. KnownUnit k => Proxy k -> r) -> r
reify 0 f = f (Proxy :: Proxy '())
reify n f = reify (n - 1) \$ \(Proxy :: Proxy k)
-> f (Proxy :: Proxy (Succ k))``````

Neat!

...or worrisome?

#### Accepting Impossible Types

We Haskellers like to use precise types in order to make illegal states unrepresentable. We accept, reluctantly, that ⊥ inhabits all types, so `()` doesn't really have exactly one possible value. But it does have exactly one possible total value, and if we write a function whose type signature expects a `()`, that's the value which this function expects to receive. And so, most functions don't document what their behaviour is on ⊥ inputs, and nobody complains, because they know they're not supposed to use ⊥ inputs.

DataKinds allows us to use precise kinds, and thus to make illegal types unrepresentable. We don't often think about them, but stuck type expressions also inhabit all kinds, so there isn't really only one type of kind `()`. Today we saw that some of those extra inhabitants are really weird. That's an interesting quirk of Haskell's type system, but ultimately, I don't think those weird inhabitants are any more worrisome than their less exotic cousins, the stuck type expressions which contain type variables. After all, there is only one total type of kind `()`, and when we write a type-level function (or an instance) which expects a `()`, that's the type we expect.

## Saturday, October 14, 2017

### Composing Declarations in Template Haskell

I have recently tried to use Template Haskell to generate both a datatype and lenses for accessing the fields of this datatype, and it was harder than it should have been. In this post, I will demonstrate the problem, I will pinpoint its cause, and I will propose a solution.

#### The Problem

Consider the following code. I'm using a simple, contrived example instead of a more realistic one because it will be easier to write Template Haskell code for generating this silly code than it would be to write Template Haskell code generating lenses and such.

``````class Default a where
def :: a

data X = X
data Y = Y X

data DoubledX = DoubledX
data DoubledY = DoubledY X X

instance Default X        where def = X
instance Default Y        where def = Y def
instance Default DoubledX where def = DoubledX
instance Default DoubledY where def = DoubledY def def``````

Most of that code is boilerplate, and I would like to generate that boilerplate using Template Haskell. I hasten to note that Template Haskell is a tool of last resort, to be used only when none of Haskell's many other abstraction facilities would have sufficed. In this example, I would probably use some generics library to define a default implementation of `def` for any algebraic datatype:

``````{-# LANGUAGE DefaultSignatures, DeriveGeneric, FlexibleContexts #-}
import Generics.Eot

class Default a where
def :: a

default def :: (HasEot a, Default (Eot a)) => a
def = fromEot def

instance Default () where
def = ()

instance (Default a, Default b) => Default (a, b) where
def = (def, def)

instance Default a => Default (Either a b) where
def = Left def

instance Default X
instance Default Y
instance Default DoubledX
instance Default DoubledY``````

This works fine, but today I want to talk about one of Template Haskell's limitations, so let's write a Template Haskell implementation instead.

``````{-# LANGUAGE TemplateHaskell #-}
import Data.List

-- > data Foo = Bar Int String
-- > generateDefault ''Foo
--
-- generates
--
-- > instance Default Foo where def = Bar def def
generateDefault :: Name -> Q [Dec]
generateDefault name = do
--      data Foo =             Bar   Int...
TyConI (DataD _ _ _ _ (NormalC cname cargs:_) _) <- reify name

-- Bar def...
let expr = foldl' (\c _ -> [|\$c def|]) (conE cname) cargs

[d|instance Default \$(conT name) where def = \$expr|]

data X = X
data Y = Y X

data DoubledX = DoubledX
data DoubledY = DoubledY X X

generateDefault ''X
generateDefault ''Y
generateDefault ''DoubledX
generateDefault ''DoubledY``````

In addition to the Default instances, we can also generate the `Doubled` datatypes, they are a version of the original datatype which has two copies of each field:

``````-- > data Foo = Bar Int String
-- > generateDoubled ''Foo
--
-- generates
--
-- > data DoubledFoo = DoubledBar Int String Int String
generateDoubled :: Name -> Q [Dec]
generateDoubled name = do
--    data Foo =             Bar   Int...
TyConI (DataD _ _ _ _ (NormalC cname cargs:_) _) <- reify name

let cons = [NormalC (doubledName cname) (cargs ++ cargs)]
pure [DataD [] (doubledName name) [] Nothing cons []]

doubledName :: Name -> Name
doubledName = mkName . ("Doubled" ++) . nameBase

data X = X
data Y = Y X

generateDoubled ''X
generateDoubled ''Y

generateDefault ''X
generateDefault ''Y
generateDefault ''DoubledX
generateDefault ''DoubledY``````

So, we can write a Template Haskell function which generates a datatype, and we can write one which generates an instance for that datatype. But can we write one which generates both the datatype and its instance? Both of our functions are `Q` actions which produce a `[Dec]`, so it looks like a no brainer: we can simply run both `Q` actions one after the other and concatenate the resulting lists.

``````generateBoth :: Name -> Q [Dec]
generateBoth name = (++) <\$> generateDoubled name
<*> generateDefault (doubledName name)

data X = X

-- error: ‘DoubledX’ is not in scope at a reify
generateBoth ''X``````

Sadness, it does not work :(

#### The Cause

The reason `DoubledX` is not in scope when `generateDefault` calls `reify ''DoubledX` is that the `DoubledX` datatype is not created as a side-effect of the `generateDoubled ''X` action, but as a side-effect of splicing the resulting `[Dec]` into the surrounding code. When concatenating the two lists, this doesn't happen until after both lists have been generated, and so `DoubledX` cannot be "reified" while generating the second list.

I didn't thought I'd ever say something like this, but: this pure API was a mistake, an API based on side-effects would be better! I'll qualify that statement though: since `reify` obtains information about datatypes (and other named entities) via a side-effect, namely reading from some global symbol table, I think there should be a corresponding action for adding new names to this table. As we have seen, with the current API in which names are added by returning a pure `[Dec]` value, declaration templates don't compose, so I think that API was a mistake.

I should note that there is, in fact, an action for adding new declarations as a side-effect:

``addTopDecls :: [Dec] -> Q ()``

Unfortunately, as of this writing, `addTopDecls` is unable to add datatypes:

``````import Language.Haskell.TH.Syntax

generateBoth :: Name -> Q [Dec]
generateBoth name = do
decs <- generateDoubled name
generateDefault (doubledName name)

data X = X

-- error: Only function, value, annotation, and foreign import
--        declarations may be added with addTopDecl
-- error: ‘DoubledX’ is not in scope at a reify
generateBoth ''X``````

So the real solution would be to fix the implementation so it also supports datatypes, but until then, I have a simpler solution.

#### Simple Solution

We can't change declaration-splicing's `Q [Dec]` API, but if we create our own API, we can write an adapter which turns it into a `Q [Dec]`.

``````{-# LANGUAGE GeneralizedNewtypeDeriving #-}

newtype LocalQ a = LocalQ { unLocalQ :: StateT [Dec] Q a }

runLocalQ :: LocalQ () -> Q [Dec]
runLocalQ = flip execStateT [] . unLocalQ``````

The idea is that in addition to `Q`'s global symbol table, `LocalQ` also has access to a local symbol table holding the declarations which have been added within the `LocalQ` computation.

``````addLocalDecls :: [Dec] -> LocalQ ()
addLocalDecls decls = LocalQ \$ modify (++ decls)

reifyLocallyFirst :: Name -> LocalQ Info
reifyLocallyFirst name = do
decls <- LocalQ get
case find (hasName name) decls of
Just dec -> pure \$ TyConI dec
Nothing  -> liftQ \$ reify name

-- for this simple example, I'm only interested
-- in datatype declarations
hasName :: Name -> Dec -> Bool
hasName expected (DataD _ actual _ _ _ _) = actual == expected
hasName _        _                        = False

liftQ :: Q a -> LocalQ a
liftQ = LocalQ . lift``````

If we reimplement our declaration templates to use this new, better API...

``````locallyGenerateDefault :: Name -> LocalQ ()
locallyGenerateDefault name = do
info <- reifyLocallyFirst name
let TyConI (DataD _ _ _ _ (NormalC cname cargs:_) _) = info
let expr = foldl' (\c _ -> [|\$c def|]) (conE cname) cargs
decls <- liftQ [d|instance Default \$(conT name) where def = \$expr|]

locallyGenerateDoubled :: Name -> LocalQ ()
locallyGenerateDoubled name = do
info <- reifyLocallyFirst name
let TyConI (DataD _ _ _ _ (NormalC cname cargs:_) _) = info
let cons = [NormalC (doubledName cname) (cargs ++ cargs)]
addLocalDecls [DataD [] (doubledName name) [] Nothing cons []]``````

...then this time we can compose them just fine:

``````locallyGenerateBoth :: Name -> LocalQ ()
locallyGenerateBoth name = do
locallyGenerateDoubled name
locallyGenerateDefault (doubledName name)

data X = X
data Y = Y X

runLocalQ \$ locallyGenerateDefault ''X
runLocalQ \$ locallyGenerateDefault ''Y
runLocalQ \$ locallyGenerateBoth ''X
runLocalQ \$ locallyGenerateBoth ''Y``````

Happiness, it works! Now all that's left is to convince everybody to rewrite their declaration templates using `LocalQ` instead of `Q`, and we'll finally be able to reuse each other's code.

#### Final Solution

Okay, so that last part is probably not going to happen. If only there was a way to monkey-patch existing `Q` code so it would use `reifyLocallyFirst` instead of `reify`...

Well, here's a little-known fact about `Q`:

``newtype Q a = Q { unQ :: forall m. Quasi m => m a }``

That's right, `Q` isn't some magic Monad which only the compiler can execute! It's a concrete type, which we can examine and manipulate however we want. The finally-tagless encoding might be a bit intimidating, but in practice, a `Q a` value is basically an AST listing which `Q` actions need to be performed in order to produce an `a`. So we should be able to dive in and replace all the `reify` calls with `reifyLocallyFirst` calls, no problem.

The finally-tagless way to do that is to write a `Quasi` instance which instantiates `reify` with `reifyLocallyFirst`, and delegates all the other operations to some other `Quasi` instance:

``````instance Quasi LocalQ where
qReify              = reifyLocallyFirst

-- Most of those aren't being exercised by my simple example,
-- so I can afford to use 'undefined' for the trickier methods.
qGetQ                   = undefined
qPutQ                   = undefined
qRecover                = undefined
qAddDependentFile   x   = liftQ \$ qAddDependentFile   x
qAddModFinalizer    x   = liftQ \$ qAddModFinalizer    x
qExtsEnabled            = liftQ \$ qExtsEnabled
qIsExtEnabled       x   = liftQ \$ qIsExtEnabled       x
qLocation               = liftQ \$ qLocation
qLookupName         x y = liftQ \$ qLookupName         x y
qNewName            x   = liftQ \$ qNewName            x
qReifyAnnotations   x   = liftQ \$ qReifyAnnotations   x
qReifyConStrictness x   = liftQ \$ qReifyConStrictness x
qReifyFixity        x   = liftQ \$ qReifyFixity        x
qReifyInstances     x y = liftQ \$ qReifyInstances     x y
qReifyModule        x   = liftQ \$ qReifyModule        x
qReifyRoles         x   = liftQ \$ qReifyRoles         x
qReport             x y = liftQ \$ qReport             x y
qRunIO              x   = liftQ \$ qRunIO              x``````

With this instance, I can now transform `Q [Dec]` templates into `LocalQ ()` templates, and the transformed version will use `reifyLocallyFirst` instead of `reify`.

``````localize :: Q [Dec] -> LocalQ ()
localize declarationTemplate = do
decls <- unQ declarationTemplate

generateBoth :: Name -> Q [Dec]
generateBoth name = runLocalQ \$ do
localize \$ generateDoubled name
localize \$ generateDefault (doubledName name)

data X = X
data Y = Y X

generateDefault ''X
generateDefault ''Y
generateBoth ''X
generateBoth ''Y``````

Notice that I am reusing the original `generateDefault` and `generateDoubled` implementations, those which caused the reify error when I first tried to implement `generateBoth`. I am not using the `locallyGenerateDefault` and `locallyGenerateDoubled` reimplementations from the previous section. This means that (with a more fleshed out implementation of `LocalQ`), I should be able to reuse any existing declaration template out there, including `Control.Lens.TH.makeLenses`! :D