<<< “lens over tea” >>>

lens over tea #6: Template Haskell

Let's take a break from weird typeclasses and delve into Template Haskell that lens uses fairly extensively; in the end we'll have a simple implementation of makeLenses. This post is fairly standalone and you don't have to have read the previous 5 posts – in fact, you don't even need to know any TH. The only thing you need to know that Template Haskell is a way to generate code while your program is compiling.

And before we begin, some funny quotes:

monochrom: Lens over Tea is really long. this is Lens over A Feast
           Spanning 5 Days
    ReinH: Or "Lens Over Teas"
    ReinH: Speaking of which, I should drink some tea.
monochrom: and each day the fabled Italian dinner which lasts 3 hours
           and 10 courses or something
monochrom: unless you're like the minister of education of Hong Kong.
           he claims he reads 30 books every month
Gurkenglas: The masterpiece of an article linked above, "lens over
            tea", whose writing style (sacrificing "ease for some to
            understand what you are talking about" for appeal to those
            who would write the same way if they sacrificed the same)
            quickly rubbed off on me, case in point.

Functions in lens that use Template Haskell

Or “know your enemy”. If you already know what makeLenses etc do, you can skip this part and start reading about Template Haskell itself.

makeLenses

Lens uses TH in order to provide makeLenses (and related functions), which you can use to automatically generate lenses for your types. Let's see it in action:

{-# LANGUAGE TemplateHaskell #-}

module Test where  -- would be needed later

import Control.Lens

data Person = Person {
  _name :: String,          -- the underscores show for which
  _age :: Double }          -- fields the lenses should be created

makeLenses ''Person
> :t name
name :: Functor f => (String -> f String) -> Person -> f Person

-- Or alternatively,
--   name :: Lens' Person String

Here's what happened. makeLenses is a function that takes a name of a datatype and produces some code.

''Person is a special syntax enabled by {-# LANGUAGE TemplateHaskell #-}. '' prepended to any type or class turns it into Name:

The produced code is “inserted” into the file during complation (it doesn't actually get written into the file, just treated as if it was there). In this case, the code looks like this:

age :: Lens' Person Double
age f (Person x1 x2) = fmap (\y -> Person x1 y) (f x2)
{-# INLINE age #-}

name :: Lens' Person String
name f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)
{-# INLINE name #-}

You can see the produced code by compiling your program with -ddump-splices (that's what we needed module Test for – otherwise GHC would've tried to compile it as a program and we'd have to add a main action):

> ghc -ddump-splices th.hs

[1 of 1] Compiling Test             ( th.hs, th.o )
th.hs:14:1-19: Splicing declarations
    makeLenses ''Person
  ======>
    age :: Lens' Person Double
    age f_a6gx (Person x_a6gy x_a6gz)
      = fmap (\ y_a6gA -> Person x_a6gy y_a6gA) (f_a6gx x_a6gz)
    {-# INLINE age #-}
    name :: Lens' Person String
    name f_a6gB (Person x_a6gC x_a6gD)
      = fmap (\ y_a6gE -> Person y_a6gE x_a6gD) (f_a6gB x_a6gC)
    {-# INLINE name #-}

(The names of variables look like this because GHC likes making all names unique.)

makeLensesFor

There are other functions available, too. makeLensesFor is like makeLenses but lets you name lenses differently:

data Person = Person {
  name :: String,
  age :: Double }

makeLensesFor [("name", "nameLens")] ''Person
nameLens :: Lens' Person String
nameLens f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)
{-# INLINE nameLens #-}

makeFields

makeFields additionally turns generated lenses into class methods (which means that now you can have records with same-named fields... well, sort of):

{-# LANGUAGE
TemplateHaskell,
MultiParamTypeClasses,     -- all these extensions are needed
FunctionalDependencies,    -- for generated instances
FlexibleInstances
  #-}

module Test where

import Control.Lens

data Person = Person {
  _personName :: String,
  _personAge :: Double }

data Animal = Animal {
  _animalSpecies :: String,
  _animalName :: Maybe String,
  _animalAge :: Double }

makeFields ''Person
makeFields ''Animal

Before showing you generated code, here's an example of usage:

> Person "Donald" 11 ^. name
"Donald"

> Animal "lion" Nothing 4 ^. name
Nothing

> :t name
name :: (Functor f, HasName s a) => (a -> f a) -> s -> f s

And now the code:

class HasAge s a | s -> a where
  age :: Lens' s a

instance HasAge Person Double where
  age f (Person x1 x2) = fmap (\y -> Person x1 y) (f x2)
  {-# INLINE age #-}

instance HasAge Animal Double where
  age f (Animal x1 x2 x3) = fmap (\y -> Animal x1 x2 y) (f x3)
  {-# INLINE age #-}

--------------------

class HasName s a | s -> a where
  name :: Lens' s a

instance HasName Person String where
  name f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)
  {-# INLINE name #-}

instance HasName Animal (Maybe String) where
  name f (Animal x1 x2 x3) = fmap (\y -> Animal x1 y x3) (f x2)
  {-# INLINE name #-}

--------------------

class HasSpecies s a | s -> a where
  species :: Lens' s a

instance HasSpecies Animal String where
  species f (Animal x1 x2 x3) = fmap (\y -> Animal y x2 x3) (f x1)
  {-# INLINE species #-}

makeClassy

makeClassy is pretty similar to makeLenses, but it has an extra feature that makes it very useful in some situations. Like makeFields, it makes lenses methods of a class:

data Person = Person {
  _name :: String,
  _age :: Double }
class HasPerson c where
  person :: Lens' c Person

  age :: Lens' c Double
  age = person.age
  {-# INLINE age #-}

  name :: Lens' c String
  name = person.name
  {-# INLINE name #-}

instance HasPerson Person where
  person = id

  name f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)
  {-# INLINE name #-}

  age f (Person x1 x2) = fmap (\y -> Person x1 y) (f x2)
  {-# INLINE age #-}

However, it doesn't create a separate class for each field – instead it creates a single class for the type, which normally wouldn't be more useful than makeLenses, but it becomes useful when you have a hierarchy of types. For instance, let's say that you have beings (which have an age), people (who have an age and a name), and workers (who have an age, a name, and a job, unlike me). If you used makeFields, you'd just create records with fields called personAge, personName, workerAge, workerJob, etc, and it'd work – but it feels somewhat ad-hoc. makeClasses lets us expicitly show that they are a hierarchy:

data Being = Being {
  _age :: Double }

data Person = Person {
  _personBeing :: Being,
  _name :: String }

data Worker = Worker {
  _workerPerson :: Person,
  _job :: String }

makeClassy ''Being
makeClassy ''Person
makeClassy ''Worker

The magic sauce is these 3 instances you have to define manually:

instance HasBeing Person where being = personBeing
instance HasPerson Worker where person = workerPerson

instance HasBeing Worker where being = person.being

Now you can use age/name/job to access age/name/job of anybody who has it, and you also can “downgrade” types (Worker to Person, or Person to Being, or Worker to Being) by using the person and being lenses.

makePrisms

Next is makePrisms, which generates prisms for sum types (while makeLenses generates lenses for product types):

data Foobar a
  = Foo a
  | Bar Int Char
  deriving Show

makePrisms ''Foobar

Again, an example first:

> Bar 3 'a' ^? _Foo
Nothing

> Bar 3 'a' ^? _Bar
Just (3,'a')

> Bar 3 'a' ^? _Bar._1
Just 3

> _Foo # False
Foo False

And now generated code:

-- prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

_Foo :: Prism (Foobar a) (Foobar b) a b
_Foo = prism (\x -> Foo x)
             (\x -> case x of
                      Foo y -> Right y
                      Bar y1 y2 -> Left (Bar y1 y2))

_Bar :: Prism' (Foobar a) (Int, Char)
_Bar = prism
         (\(x1, x2) -> Bar x1 x2)
         (\x -> case x of
                  Bar y1 y2 -> Right (y1, y2)
                  _ -> Left x)

makeLensesWith

makeLenses, makeLensesFor, and makeFields all call makeLensesWith under the hood. It takes a record with settings, and produces lenses according to those settings. (The settings include “whether or not make classes”, “how to call resulting lenses”, etc.) We'll look at those settings later; you can see the list of them here (scroll down a bit, to the “configuration accessors” section).

declareLenses

declareLenses lets you make lenses for a record without creating record accessors (i.e. underscored fields). To do it, you have to pass the whole declaration to the function:

declareLenses [d|
  data Person = Person {
    name :: String,
    age :: Double }
  |]

Similarly to how ''Person isn't a type but a Name, any code in [| |] brackets isn't code, but representation of that code. declareLenses inspects that representation, generates lenses based on it, changes it, and the result is added to the file. In this case, the result is this:

data Person = Person String Double

name :: Lens' Person String
name f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)
{-# INLINE name #-}

age :: Lens' Person Double
age f (Person x1 x2) = fmap (\y -> Person x1 y) (f x2)
{-# INLINE age #-}

(The drawback of declareLenses in comparison to makeLenses is that now in order to construct Person you have to write Person x y instead of more understandable and less error-prone Person {_name = x, _age = y}.)

Template Haskell

Any Haskell code can be represented as a value of one of the types from template-haskell (specifically, from the Language.Haskell.TH module). There are separate types for expressions, for patterns, for declarations, for types, and for other things.

For a while this piece of code is going to be our case study:

map2 :: (a -> b) -> [a] -> [b]
map2 f (x:xs) = f x : map2 f xs
map2 _ [] = []

[] and f x : map2 f xs are expressions, f, _, [], and (x:xs) are patterns, (a -> b) -> [a] -> [b] is a type, and the whole thing is a declaration (well, actually 2 declarations – the type signature and the function itself).

Expressions

Let's start with expressions, because I like them most – they're doing all the work and the rest is just supporting cast. Expressions are represented by the type Exp:

data Exp
  = VarE Name
  | ConE Name
  | AppE Exp Exp
  | InfixE (Maybe Exp) Exp (Maybe Exp)
  | LitE Lit
  ...

To create new Names, you can use mkName:

mkName :: String -> Name

To refer to already existing things in scope, use '. For instance, 'id refers to id from Prelude, and '(:) refers to the list constructor.

Okay, now you know everything you need to write f x : map2 f xs as an Exp. (Yeah, this is an exercise.) If you've done everything correctly, you should be able to use pprint (short for “pretty-print”) on your expression to see the code:

> pprint $ ...
"f x GHC.Types.: map2 f xs"

(The reason you're oing to see GHC.Types.: instead of : is that all names generated by TH (excluding the ones defined in the current module) are qualified, and : is exported by Prelude but originally it's from GHC.Types.)

Okay, so, have you done it?

The result should look like this if you hate typing repetitive things over and over again:

var = VarE . mkName
($$) = AppE

res = InfixE
  (Just (var "f" $$ var "x"))
  (VarE '(:))
  (Just (var "map2" $$ var "f" $$ var "xs"))

Or like this if you don't mind:

res = InfixE
  (Just (AppE (VarE (mkName "f"))
              (VarE (mkName "x"))))
  (VarE '(:))
  (Just (AppE (AppE (VarE (mkName "map2"))
                    (VarE (mkName "f")))
              (VarE (mkName "xs"))))

Patterns

Patterns are represented by the type Pat:

data Exp
  = VarP Name
  | ConP Name [Pat]
  | InfixP Pat Name Pat
  | WildP
  | LitP Lit
  | TupP [Pat]
  | ListP [Pat]
  ...

Types

Types are represented by the type Type:

data Type
  = ForallT [TyVarBndr] Cxt Type
  | AppT Type Type
  | VarT Name
  | ConT Name
  | ArrowT
  | ListT
  ...

AppT and VarT should be obvious; ConT refers to type constructors (like Int or Maybe); ArrowT is a special name for -> (but you still have to apply it to types with AppT), and ListT is a special name for []. ForallT is the forall in this type signature:

id :: forall a. a -> a
id x = x

You can omit it when you write ordinary Haskell, but you can't omit it when you're creating a Type – so, whenever you use a VarT, the variable must first be declared by a ForallT.

ForallT takes 3 arguments – a list of variables, context (e.g. Ord a) (so, just a list of constraints), and a type. Variables can be defined like this:

data TyVarBndr
  = PlainTV Name
  | KindedTV Name Kind

Here PlainTV is what we need (and KindedTV is for variables with kinds but variables almost always don't have explicit kind annotations so it doesn't matter right now).

Ugh, that was a lot of details. To make it a bit easier, I'll write down the type of id:

idT = ForallT
        [PlainTV (mkName "a")]
        []
        (ArrowT `AppT` VarT (mkName "a") `AppT` VarT (mkName "a"))
> pprint idT
"forall a . a -> a"

And now that you know all that, try to encode map2's type by yourself.

Declarations

Declarations are represented by Dec, and pretty much everything is a declaration:

data Dec
  = FunD Name [Clause]                            -- functions
  | ValD Pat Body [Dec]                           -- values
  | DataD Cxt Name [TyVarBndr] [Con] [Name]       -- datatypes
  | NewtypeD Cxt Name [TyVarBndr] Con [Name]      -- newtypes
  | TySynD Name [TyVarBndr] Type                  -- type synonyms
  | ClassD Cxt Name [TyVarBndr] [FunDep] [Dec]    -- classes
  | InstanceD Cxt Type [Dec]                      -- instances
  | SigD Name Type                                -- signatures
  ...

We're only going to use FunD and SigD right now, so let's look at Clause and Body:

data Clause = Clause [Pat] Body [Dec]

data Body
  = GuardedB [(Guard, Exp)]
  | NormalB Exp

A Clause is a single equation in a function declaration – it includes function arguments and where, but doesn't include the function name. A Body is either an expression or a bunch of guards-and-expressions, but we're not going to look at guards because they're another rabbit hole leading to lots of new types that we don't need right now.

Putting it all together

First you try, then I'll show you the code. Your task is to write map2TH:

map2TH :: [Dec]
map2TH = ...

that would, when you pretty-print it (putStrLn . pprint), produce the following code:

map2 :: forall a b . (a -> b) -> [a] -> [b]
map2 f (x GHC.Types.: xs) = f x GHC.Types.: map2 f xs
map2 _ (GHC.Types.[]) = GHC.Types.[]

Just in case, without annoying GHC.Types. it looks like this:

map2 :: (a -> b) -> [a] -> [b]
map2 f (x:xs) = f x : map2 f xs
map2 _ [] = []

When you're done, you should be able to inject it into GHCi and test it. You'd have to use GHCi, because you can't just write map2TH on a separate line and have it work the same way makeLenses works – a restriction of TH is that the generated code and the generating code have to be in different modules. Here's how to test TH code in GHCi:

> data X; return map2TH    -- don't worry about “data X” now

> map2 (+1) [1,2,3]
[2,3,4]

Finally, here are some utilities that might save you typing:

(->>) a b = ArrowT `AppT` a `AppT` b
infixr 9 ->>

($$) f a = AppE f a
infixl 9 $$

The answer

(->>) a b = ArrowT `AppT` a `AppT` b
infixr 9 ->>

($$) f a = AppE f a
infixl 9 $$

map2TH :: [Dec]
map2TH = [signature, function]
  where
    -- Names
    map2 = mkName "map2"

    -- Type signature
    a = VarT (mkName "a")
    b = VarT (mkName "b")
    type' = ForallT [PlainTV (mkName "a"), PlainTV (mkName "b")] [] $
              (a ->> b) ->> AppT ListT a ->> AppT ListT b
    signature = SigD map2 type'

    -- Variables and patterns
    (fPat, fExp) = (VarP (mkName "f"), VarE (mkName "f"))
    (xPat, xExp) = (VarP (mkName "x"), VarE (mkName "x"))
    (xsPat, xsExp) = (VarP (mkName "xs"), VarE (mkName "xs"))

    -- first equation
    eq1 = Clause
            -- arguments
            [fPat, InfixP xPat '(:) xsPat]
            -- result
            (NormalB (InfixE (Just (fExp $$ xExp))
                             (ConE '(:))
                             (Just (VarE map2 $$ fExp $$ xsExp))))
            -- no “where” block
            []

    -- second equation
    eq2 = Clause [WildP, ConP '[] []]
                 (NormalB (ConE '[]))
                 []

    -- Function body
    function = FunD map2 [eq1, eq2]

Oxford brackets (or [| |]s)

If you're used to Lisp macros, this might seem horrible to you, and it is pretty horrible indeed. Why are we writing the AST by hand when we have a compiler that can parse Haskell into a syntax tree for us?

Well, we don't have to, and I actually have mentioned it earlier in this post:

any code in [| |] brackets isn't code, but representation of that code

In other words, that whole thing could've just been replaced with this:

map2TH :: Q [Dec]
map2TH = [d|
  map2 :: (a -> b) -> [a] -> [b]
  map2 f (x:xs) = f x : map2 f xs
  map2 _ [] = []
  |]

Now you should be expecting me to tell you answers to asking yourself several questions:

  1. What does Q do?
  2. What kind of a non-informative name is that?
  3. Also, why [d| |] instead of [| |] as the quote says?

The answer to the third question is easy. There are 5 types of brackets:

The answer to the second question is easy too (I think) – my theory is that TH code is usually messy and awkward and awful, and things with Q occur very often there, so the shortest name possible was chosen. In fact, even Q [Dec] is too long – we have a type synonym for that, DecsQ. (Try to guess the synonyms for Q Exp and Q Pat.)

Now we come to the first question. What's Q?

The Q monad

The Q monad is a monad for generating code. The difference between it and just writing-an-AST-by-hand is that in the Q monad you can:

Note that the IO is going to happen during compilation, because that's when TH is run). This is pretty useful, but it also should make you a tiny bit nervous because it means that any package from Hackage can remove your home directory when you do cabal install. (There are worse things that others could do to you, tho.)

Anyway, the next task is generating a simple lens for a 2-tuple:

-- The name should be configurable
<some name> :: Lens (a, x) (b, x) a b
<some name> f (a, x) = (\b -> (b, x)) <$> f a

Here are some notes that should help you:

When you're done, test it:

> data X; fstLensTH "fstL"

> (1,2) ^. fstL
1

The answer

mkVars :: String -> Q (PatQ, ExpQ)
mkVars name = do
  x <- newName name
  return (varP x, varE x)

fstLensTH :: String -> DecsQ
fstLensTH lensName = do
  -- Generate the signature
  signature <- sigD (mkName lensName)
                    [t|forall a b x. Lens (a, x) (b, x) a b|]

  -- Generate the body of the function
  (f_, f) <- mkVars "f"
  (a_, a) <- mkVars "a"
  (b_, b) <- mkVars "b"
  (x_, x) <- mkVars "x"
  body <- funD (mkName lensName) [
            clause [f_, tupP [a_, x_]]
                   (normalB [|(\ $b_ -> ($b, $x)) <$> $f $a|])
                   []
            ]

  -- Return the signature and the body
  return [signature, body]

The explanation of the data X thing

When you're compiling a module, you don't have to use any data X to splice generated code into it; you can just write this and generated definitions would be spliced into the file:

fstLensTH "fstL"
-- or this
$(fstLensTH "fstL)

However, for whatever reason GHCi can't normally guess when you want to splice something:

> fstLensTH "fstL"

<interactive>:
    No instance for (Show DecsQ)
      arising from a use of ‘print’
    In a stmt of an interactive GHCi command: print it

> $(fstLensTH "fstL")

<interactive>:513:3:
    Couldn't match type ‘[Dec]’ with ‘ExpExpected type: ExpQ
      Actual type: DecsQ
    In the expression: fstLensTH "fstL"
    In the splice: $(fstLensTH "fstL")

And data X is needed to hint GHCi that it's being given declarations and thus should treat the splice as yet another declaration. It's ad-hoc, but it works.

Another exercise

Modify fstLensTH to generate a lens for a n-tuple:

-- >>> fstLensTH "fst4" 4
-- fst4 :: forall a b x1 x2 x3. Lens (a, x1, x2, x3) (b, x1, x2, x3) a b
-- fts4 f (a, x1, x2, x3) = (\b -> (b, x1, x2, x3)) <$> f a

fstLensTH :: String -> Int -> DecsQ

Notes:

The answer

import Data.Traversable

mkVars :: String -> Q (PatQ, ExpQ)
mkVars name = do
  x <- newName name
  return (varP x, varE x)

-- >>> fstType 4
-- forall a b x1 x2 x3. Lens (a, x1, x2, x3) (b, x1, x2, x3) a b
fstType :: Int -> TypeQ
fstType n = do
  xs <- for [1..n-1] (\i -> newName ("x" ++ show i))
  a <- newName "a"
  b <- newName "b"
  -- foldl appT (tupleT n) :: [TypeQ] -> TypeQ
  let tupleA = foldl appT (tupleT n) (map varT (a:xs))
      tupleB = foldl appT (tupleT n) (map varT (b:xs))
  forallT (map PlainTV (a:b:xs))
          (cxt [])
          [t|Lens $tupleA $tupleB $(varT a) $(varT b)|]

-- >>> fstClause 4
-- ? f (a, x1, x2, x3) = (\b -> (b, x1, x2, x3)) <$> f a
fstClause :: Int -> ClauseQ
fstClause n = do
  (f_, f) <- mkVars "f"
  (a_, a) <- mkVars "a"
  (b_, b) <- mkVars "b"
  -- Generate x1, x2, ..., xn
  (xs_, xs) <- unzip <$> for [1..n-1] (\i -> mkVars ("x" ++ show i))
  clause [f_, tupP (a_:xs_)]
         (normalB [|(\ $b_ -> $(tupE (b:xs))) <$> $f $a|])
         []

fstLensTH :: String -> Int -> DecsQ
fstLensTH lensName n = do
  signature <- sigD (mkName lensName) (fstType n)
  body <- funD (mkName lensName) [fstClause n]
  return [signature, body]

Getting information about types

The next step to makeLenses is getting information about a type. This is done by reify:

reify :: Name -> Q Info

Info is a structure that looks like this:

data Info
  = ClassI Dec [InstanceDec]              -- Class and its instances
  | TyConI Dec                            -- Type constructor
  | DataConI Name Type ParentName Fixity  -- Data constructor
  | ClassOpI Name Type ParentName Fixity  -- Class method
  | VarI Name Type (Maybe Dec) Fixity     -- Variable/function
  ...

(Unfortunately, you can't actually get definitions of functions using VarI, but we won't need it anyway so it doesn't matter.)

Let's try reify:

> runQ (reify ''Bool)
Template Haskell error: Can't do `reify' in the IO monad
*** Exception: user error (Template Haskell failure)

Ouch.

The reason for the error is that GHC only provides information about types/values to splices, so we'd have to run reify inside a splice. That's not hard to do:

> $(reify ''Bool)

<interactive>:
    Couldn't match typeInfo’ with ‘ExpExpected type: ExpQ
      Actual type: Q Info
    In the expression: reify ''Bool
    In the splice: $(reify ''Bool)

No, wait, we need Exp, right. Well, let's pretty-print Info and then turn it into a string literal:

> $(stringE . pprint =<< reify ''Bool)
"data GHC.Types.Bool = GHC.Types.False | GHC.Types.True"

Hm, pretty-printing is actually not that helpful in this case. Just use show, then:

> $(stringE . show =<< reify ''Bool)
"TyConI (DataD
           []                              -- no constaints
           GHC.Types.Bool                  -- “Bool =”
           []                              -- no type variables
           [ NormalC GHC.Types.False [],   -- False |
             NormalC GHC.Types.True  [] ]  -- True
           [])"                            -- not deriving anything
                                           --   (TH lies to us in this
                                           --   case, but whatever)

(Indentation is mine.)

What would happen if we used a record?

data Person = Person {
  name :: String,
  age :: Double }
> $(stringE . show =<< reify ''Person)
"TyConI (DataD
           []
           Test.Person
           []
           [RecC Test.Person
              [ (Test.name,NotStrict,ConT GHC.Base.String),
                (Test.age ,NotStrict,ConT GHC.Types.Double) ] ]
           [])"

Okay, now you should be able to write a function that takes a record name and returns a list of its fields. nameBase would be useful (it takes a Name and returns just the name without the module).

If you've written it correctly, here's how you can test it:

> $(listE . map stringE =<< listFields ''Person)
["Person.name","Person.age"]

The answer:

listFields :: Name -> Q [String]
listFields name = do
  -- A warning: with GHC 8, you'll have to add an extra “_” before “cons”
  TyConI (DataD _ _ _ cons _) <- reify name
  return [nameBase conName ++ "." ++ nameBase fieldName
         | RecC conName fields <- cons
         , (fieldName, _, _) <- fields]

Writing a very simple version of makeLenses

For now let's only look at records with 1 constructor and no type variables. The goal is to take

data Person = Person {
  _name :: String,
  _age :: Double }

and write something that would generate the following (skip the fields that don't begin with a _):

age :: Lens' Person Double
age f (Person x1 x2) = fmap (\y -> Person x1 y) (f x2)

name :: Lens' Person String
name f (Person x1 x2) = fmap (\y -> Person y x2) (f x1)

You might find the following 2 functions slightly useful:

Also, if you need a hint, here it is: if you split it into makeLenses and makeLens, the signature of makeLens would look approximately like this:

makeLens
  :: Name    -- ^ Type name
  -> Name    -- ^ Constructor name
  -> Name    -- ^ Lens name
  -> Type    -- ^ Field type
  -> Int     -- ^ Field position in the constructor
  -> Int     -- ^ Overall fields amount
  -> DecsQ

The answer

makeLenses :: Name -> DecsQ
makeLenses typeName = do
  -- Get constructors:
  --
  --   cons :: [Con]
  TyConI (DataD _ _ [] cons _) <- reify typeName

  -- Get the constructor name and its fields:
  --
  --   conName :: Name
  --   fields  :: [VarStrictType] :: [(Name, Strict, Type)]
  [RecC conName fields] <- return cons

  -- Make the lenses (concat is needed because for is going to return Q
  -- [[Dec]], and we need just Q [Dec])
  fmap concat $
    for (zip fields [0..]) $ \((fieldName, _, fieldType), fieldPos) ->
      case nameBase fieldName of
        ('_':rest) -> makeLens typeName conName (mkName rest)
                               fieldType fieldPos (length fields)
        _ -> return []

makeLens
  :: Name    -- ^ Type name
  -> Name    -- ^ Constructor name
  -> Name    -- ^ Lens name
  -> Type    -- ^ Field type
  -> Int     -- ^ Field position in the constructor
  -> Int     -- ^ Overall fields amount
  -> DecsQ
makeLens typeName conName lensName fieldType fieldPos fieldCount = do
  -- The signature
  let type_ = [t|Lens' $(conT typeName) $(return fieldType)|]
  signature <- sigD lensName type_

  -- The lens
  (f_, f) <- mkVars "f"
  (y_, y) <- mkVars "y"
  (xs_, xs) <- unzip <$> for [0..fieldCount-1] (\i -> mkVars ("x" ++ show i))
  -- lam  = (\y -> Con ...)
  -- pats = ? f (Con x1 x2 ...)
  -- rhs  = fmap lam (f xi)
  let lam  = lam1E y_ (appsE (conE conName : (xs & ix fieldPos .~ y)))
      pats = [f_, conP conName xs_]
      rhs  = [|fmap $lam ($f $(xs !! fieldPos))|]
  body <- funD lensName [clause pats (normalB rhs) []]

  -- All together
  return [signature, body]

mkVars :: String -> Q (PatQ, ExpQ)
mkVars name = do
  x <- newName name
  return (varP x, varE x)

By the way, the fmap concat trick is also useful when you want to create lenses for several types – instead of writing

makeLenses ''A
makeLenses ''B
makeLenses ''C

you can write

concat <$> mapM makeLenses [''A, ''B, ''C]

Type variables

At the moment our makeLenses won't work for something like this (in particular, it's going to fail with a pattern match failure):

data Person a = Person {
  _name :: a,
  _age :: Double }
  deriving (Show)

Notes:

The answer

makeLenses :: Name -> DecsQ
makeLenses typeName = do
  -- Get constructors and variables:
  --
  --   cons :: [Con]
  --   vars :: [TyVarBndr]
  TyConI (DataD _ _ vars cons _) <- reify typeName

  -- The full type, thus, is:
  let fullType :: Type
      fullType = typeName `conAppsT` [VarT (v ^. name) | v <- vars]

  -- Get the constructor name and its fields:
  --
  --   conName :: Name
  --   fields  :: [VarStrictType] :: [(Name, Strict, Type)]
  [RecC conName fields] <- return cons

  -- Make the lenses (concat is needed because for is going to return Q
  -- [[Dec]], and we need just Q [Dec])
  fmap concat $
    for (zip fields [0..]) $ \((fieldName, _, fieldType), fieldPos) ->
      case nameBase fieldName of
        ('_':rest) -> makeLens fullType conName (mkName rest)
                               fieldType fieldPos (length fields)
        _ -> return []

makeLens
  :: Type    -- ^ Type
  -> Name    -- ^ Constructor name
  -> Name    -- ^ Lens name
  -> Type    -- ^ Field type
  -> Int     -- ^ Field position in the constructor
  -> Int     -- ^ Overall fields amount
  -> DecsQ
makeLens fullType conName lensName fieldType fieldPos fieldCount = do
  -- The signature
  let type_ = quantifyType (conAppsT ''Lens' [fullType, fieldType])
  -- (We could have “type_” in the Q monad and use [| |], but there's no
  -- reason to do it and I also wanted to showcase conAppsT)
  let signature = SigD lensName type_

  -- The lens
  (f_, f) <- mkVars "f"
  (y_, y) <- mkVars "y"
  (xs_, xs) <- unzip <$> for [0..fieldCount-1] (\i -> mkVars ("x" ++ show i))
  -- lam  = (\y -> Con ...)
  -- pats = ? f (Con x1 x2 ...)
  -- rhs  = fmap lam (f xi)
  let lam  = lam1E y_ (appsE (conE conName : (xs & ix fieldPos .~ y)))
      pats = [f_, conP conName xs_]
      rhs  = [|fmap $lam ($f $(xs !! fieldPos))|]
  body <- funD lensName [clause pats (normalB rhs) []]

  -- All together
  return [signature, body]

quantifyType :: Type -> Type
quantifyType t = ForallT vs [] t
  where
    vs = map PlainTV (nub (t ^.. typeVars))

mkVars :: String -> Q (PatQ, ExpQ)
mkVars name = do
  x <- newName name
  return (varP x, varE x)

What to do next

Okay, now you can write your own simple makeLenses! How is it different from lens's makeLenses?

Most of lens's TH code (excluding code that generates prisms) lives in Control.Lens.Internal.FieldTH. If you want your makeLenses to be close to lens's makeLenses, you should:

And that's pretty much all (unless you also want to generate classes, in which case it's not).

P.S.

Here's a poll about possibly maybe turning lens over tea into a book when it's finished. Please fill it; if you don't, the sample would be really really skewed and the poll would be worthless. (Well, it's already moderately worthless since you have to be reading this in order to participate, but if you read this and don't participate it would be totally worthless.)

Thanks for caring about statistics.

<<< “lens over tea” >>>
Read next: Telegram channel