Thursday, May 28, 2020

Yes, I approve of your license.

In the world of open source, changing the license, or introducing an official license on code which previously didn't have any, can be difficult because all the contributors, including the contributors who are no longer active, need to approve the change. In an effort to make things slightly easier for the open source projects to which I have contributed, I, Samuel GĂ©lineau, also known online as "gelisam" and "haskell_cat", hereby accept any license change requested by the current maintainers of a project.

Clarifications:
  • This applies to all projects, not only to projects which meet some definition of "open source".
  • It doesn't matter whether the new license meets some definition of "open source".
  • The goal is not for me to receive fewer requests to approve a license change, but to allow the license change to go through even if I cannot be reached.

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
instance MyMonad Maybe

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

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 as, 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 Succs. Using polymorphic recursion, it is also possible to go the other way, from an integer to a stuck type expression containing that many Succs:

{-# 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 Succs. So we start with n, we convert it to a stuck type containing n Succs, and then we count those Succs 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
import Language.Haskell.TH

-- > 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
  addTopDecls decs
  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 }
  deriving (Functor, Applicative, Monad, MonadFail)

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|]
  addLocalDecls decls

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
  qAddTopDecls        = addLocalDecls
  
  -- 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
  addLocalDecls decls

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

Saturday, December 26, 2015

A whirlwind tour of Haskell, day 8

Day 8, functionally: pattern-matching

Today's puzzle involves parsing: we are given a string literal containing escape sequences, and we must interpret those escape sequences into the characters they represent. Or at least into the correct number of characters, whatever.

In my puzzle solutions so far, I have always pattern-matched at most one level deep, meaning that the pattern if any was always of the form (Constructor arg1 arg2 ...). Instead of binding those arguments to variables, I can also choose to nest more constructors. When pattern-matching on the list of characters of a string, nesting multiple patterns allows me to match on several characters at once, making it easy to recognize each of the three escape sequences specified in the puzzle using one pattern each.

import Data.Char

-- |
-- >>> print (parse "\"(\x20\\\"\x20)\"")
-- "( \" )"
parse :: String -> String
parse ('"':xs0) = go xs0
  where
    go []                  = error "unterminated string literal"
    go ('"'           :[]) = []
    go ('\\':'\\'     :xs) = '\\'      : go xs
    go ('\\':'"'      :xs) = '"'       : go xs
    go ('\\':'x':x1:x2:xs) = hex x1 x2 : go xs
    go (x             :xs) = x         : go xs
parse _ = error "not a string literal"

hex :: Char -> Char -> Char
hex c1 c2 = chr (16 * digitToInt c1 + digitToInt c2)

If we were writing an imperative implementation, we would probably have some kind of current index into the string which we would increment by 1, 2, or 4 characters depending on the pattern. It would be easy to accidentally increment that index by the wrong number of characters. By contrast, notice how the pattern-matching approach is less error-prone, as it naturally encourages us to give a name to the part of the string which isn't covered by each pattern.

Day 8.5, combinatorially: invertible-syntax

Once the second part is revealed, we can see that the complete puzzle consists of two related tasks: parsing a string literal into a string value, and pretty-printing a string value into a string literal. Whether imperative or functional, functions convert inputs to outputs, and so it would be natural to implement both directions as two separate functions. But why restrict ourselves to functions? While Haskell is best known for being a purely functional programming language, "functional" programming does not imply that everything is a function. In fact, we regularly construct other abstractions, new kinds of building blocks which can be composed into larger ones: the "combinator libraries" I briefly mentioned on Day 1. So let's put on our combinatorial glasses, step away from functions for a bit, and ask ourselves: What kind of building blocks would be useful for this problem? How can those building blocks be composed into larger building blocks?

The invertible-syntax library proposes the following approach: each building block shall know how to parse and to pretty print a value of a particular type, for example a character, and those building blocks can be combined into larger building blocks that know how to parse and pretty-print more complicated values, for example a string.

As usual, I'll write doctest comments above each definition to demonstrate what each building block does. Since I almost always want to demonstrate that a string s parses into a value x and that this same value x pretty-prints into the same string s, I'll use the following helper function to test both directions at once.

{-# LANGUAGE RankNTypes #-}
import Prelude hiding (print, pure, (<$>), (<*), (<*>), (*>))
import Text.Syntax
import Text.Syntax.Parser.Naive
import Text.Syntax.Printer.Naive

-- |
-- >>> test (pure 42) "" 42
-- True
-- >>> test (text "foo") "foo" ()
-- True
test :: Eq a => (forall f. Syntax f => f a) -> String -> a -> Bool
test block s x = (parsedValue == x) && (printedString == Just s)
  where
    parsedValue = head (parse block s)
    printedString = print block x

The two primitive building blocks I have demonstrated in the doctest comment are dual to each other: pure consumes no characters when parsing and always produces the same value, while text always consumes the same characters and doesn't produce anything useful as its value. They can be combined to describe "atoms", that is, a particular value which is represented using a particular string. Useful atoms for this puzzle include the backslash and double quote characters, which are represented using their respective escape sequences.

atom :: (Eq a, Syntax f) => String -> a -> f a
atom s x = pure x <* text s

-- |
-- >>> test backslash "\\\\" '\\'
-- True
backslash :: Syntax f => f Char
backslash = atom "\\\\" '\\'

-- |
-- >>> test doubleQuote "\\\"" '\"'
-- True
doubleQuote :: Syntax f => f Char
doubleQuote = atom "\\\"" '\"'

The hexadecimal escape sequence is a bit more complicated. I'll build it out of smaller atoms, one for each hexadecimal digit:

type Word4 = Int
type Word8 = Int

-- |
-- >>> test (hexDigits !! 12) "c" 12
-- True
hexDigits :: Syntax f => [f Word4]
hexDigits = [atom [intToDigit i] i | i <- [0..15]]

oneOf :: Syntax f => [f a] -> f a
oneOf = foldr (<|>) empty

-- |
-- >>> test hexDigit "a" 10
-- True
hexDigit :: Syntax f => f Word4
hexDigit = oneOf hexDigits

I've used the binary choice combinator (<|>) from invertible-syntax to construct an n-ary choice operator oneOf acting on lists, and I used it to combine my atoms into a more useful building block hexDigit which can parse and pretty-print any hex digit.

Next, I'd like to combine two of those into a full byte, but with only the invertible-syntax combinators, I can only combine them into a pair of nibbles (a number between 0 and 15):

-- |
-- >>> test nibbles "6f" (6, 15)
-- True
nibbles :: Syntax f => f (Word4, Word4)
nibbles = hexDigit <*> hexDigit

Given a pair of nibbles, I can easily compute the value of the corresponding byte. However, since our building blocks are going in both directions, we will also need a formula for splitting a byte into a pair of nibbles. This way, the parsing process will extract two nibbles and merge them into a byte, and the pretty-printing process will split the byte into two nibbles and will pretty-print each one.

import Control.Isomorphism.Partial.Prim
import Control.Isomorphism.Partial.Unsafe

iso :: (a -> b) -> (b -> a) -> Iso a b
iso f g = Iso (Just . f) (Just . g)

mergeNibbles :: Iso (Word4, Word4) Word8
mergeNibbles = iso (\(x,y) -> x * 16 + y) (`divMod` 16)

-- |
-- >>> test byte "6f" 111
-- True
byte :: Syntax f => f Word8
byte = mergeNibbles <$> nibbles

-- |
-- >>> test hexChar "\\x6f" 'o'
-- True
hexChar :: Syntax f => f Char
hexChar = iso chr ord <$> text "\\x" *> byte

invertible-syntax has a companion library called partial-isomorphisms for constructing such pairs of inverse functions. It is a combinator library in its own right, with many primitives and combinators ensuring that the resulting functions really are inverses of each other, but in this case I prefer to use the unsafe portion of the library, which allows me to specify an arbitrary pair of functions and to tell the library to trust me that those are inverses of each other.

Now that we have covered all the escape sequences, the last kind of character which could occur in a string is a non-escaped character.

-- |
-- >>> test otherChar "o" 'o'
-- True
otherChar :: Syntax f => f Char
otherChar = subset (`notElem` ['\\','\"']) <$> token

subset builds a partial isomorphism by taking the identity isomorphism which doesn't change the value in either direction, and restricting its domain to the values satisfying a predicate. In this case, we don't want backslash and double quote characters to be included in the domain of non-escaped characters, because those characters do need to be escaped.

So far I've been talking about functions going in two directions as if the two functions were true inverses of each other, but in fact as the name implies, partial isomorphisms are only partial inverses. The reason we don't need the functions to be exact inverses is that a given value may have several different, equally valid textual representations. For example, the character 'o' can be represented either as "o" or as "\x6f", and both encodings are valid. But when we convert those two representations to the single value 'o' and then back to a string, the function which converts 'o' into a string can only choose one answer! Suppose it chooses "o": the other value, "\x6f", demonstrates that the functions are not inverses, because applying one function to "\x6f" yields 'o' but applying the other function to 'o' does not yield back "\x6f".

Now that we have building blocks for every kind of character, we can combine them into one more complicated building block which knows how to parse and pretty-print any character.

-- |
-- >>> test char "o" 'o'
-- True
-- >>> head (parse char "\x6f")
-- 'o'
-- >>> print char 'o'
-- Just "o"
char :: Syntax f => f Char
char = oneOf [backslash, doubleQuote, otherChar, hexChar]

While parsing, escaped backslashes and double quotes will be parsed into backslashes and double quotes, non-escaped characters will be parsed into themselves, and escaped hexadecimal codes will be parsed into the corresponding ascii character. When pretty-printing, however, no characters will be printed in hexadecimal, because every character is either a backslash, a double quote, or in the domain of otherChar. So the pretty printer will never fall back to hexChar, and 'o' will be printed as "o", not "\x6f". We could of course have chosen otherwise by ordering the list of building blocks differently.

Now that we can handle characters, we're finally ready to describe how to handle an entire string.

-- |
-- >>> test string "\"( \\\" )\"" "( \" )"
-- True
-- >>> head (parse string "\"(\x20\\\"\x20)\"")
-- "( \" )"
-- >>> print string "( \" )"
-- Just "\"( \\\" )\""
string :: Syntax f => f String
string = between (text "\"") (text "\"") (many char)

This approach ended up requiring much more code than simply writing separate functions for parsing and pretty-printing strings. It is, however, much less error-prone: if we end up changing the way in which strings can be represented, for example by supporting more kinds of escape sequences, we will only have to modify the code once. In contrast, with two separate functions, it would be easy to forget to update the other function, or to accidentally modify the functions in a way which causes them to no longer be partial inverses.

Navigation

Friday, December 25, 2015

A whirlwind tour of Haskell, day 7

Day 7, functionally: bit fiddling, Map, and recursion

Today's puzzle is quite interesting, and will allow me to demonstrate several Haskell techniques! We're given the description of an electronic circuit consisting of a bunch of constants and bitwise operations, and we need to simulate it. The bitwise operations are fairly standard, here's what they look like in Haskell:

import Data.Word
import Data.Bits

opAND :: Word16 -> Word16 -> Word16
opAND = (.&.)

opOR :: Word16 -> Word16 -> Word16
opOR = (.|.)

opLSHIFT :: Word16 -> Int -> Word16
opLSHIFT = shiftL

opRSHIFT :: Word16 -> Int -> Word16
opRSHIFT = shiftR

opNOT :: Word16 -> Word16
opNOT = complement

Like before, I'll skip the parsing details and I'll represent the operations using a precise type.

type WireName = String

data Expr
  = Number Word16
  | Wire   WireName
  | AND    Expr Expr
  | OR     Expr Expr
  | LSHIFT Expr Int
  | RSHIFT Expr Int
  | NOT    Expr
  deriving (Show, Eq)

-- (wire, expression producing its value)
type Assignment = (WireName, Expr)

Since numbers and wires are allowed both at the top-level (for example 123 -> a and w -> a) and nested inside a single operation (for example 1 OR b -> a), I found it slightly easier to allow operations to be nested into arbitrarily deep expressions. This way, I don't have to repeat my number and wire logic in two separate places.

Anyway, the tricky part of this puzzle is that those expressions aren't meant to be evaluated in the order in which they are given, as some of the wire names are used as input much earlier than the expressions which give a value to those wires. Instead, we should take our list of assignments and store them in a Map, so we'll be able to easily get the expression which produces the value of each wire.

import Data.Map (Map)
import qualified Data.Map as Map

type Env = Map WireName Expr

mkEnv :: [Assignment] -> Env
mkEnv = Map.fromList

lookupEnv :: Env -> WireName -> Maybe Expr
lookupEnv = flip Map.lookup

-- throws an exception if the name is not found
lookupEnv' :: Env -> WireName -> Expr
lookupEnv' = (Map.!)

Now that I can lookup the expression for each wire, I can evaluate expressions using a recursive solution: if the expression is a number (the base case), I'm done, if the expression depends on another wire, I lookup its expression and evaluate it using a recursive call, and if it's an operation, I recursively evaluate its operands and perform the operation. Easy!

eval :: Env -> Expr -> Word16
eval _   (Number   n) = n
eval env (Wire  name) = eval env (lookupEnv' env name)
eval env (AND    x y) = opAND    (eval env x) (eval env y)
eval env (OR     x y) = opOR     (eval env x) (eval env y)
eval env (LSHIFT x i) = opLSHIFT (eval env x) i
eval env (RSHIFT x i) = opRSHIFT (eval env x) i
eval env (NOT    x  ) = opNOT    (eval env x)

Using this solution, we can easily evaluate each of the wires given in the sample circuit:

-- |
-- >>> :{
-- let assignments = [ ("d", AND (Wire "x") (Wire "y"))
--                   , ("e", OR  (Wire "x") (Wire "y"))
--                   , ("f", LSHIFT (Wire "x") 2)
--                   , ("g", RSHIFT (Wire "y") 2)
--                   , ("h", NOT (Wire "x"))
--                   , ("i", NOT (Wire "y"))
--                   , ("x", Number 123)
--                   , ("y", Number 456)
--                   ]
--     wireNames   = map fst assignments
--     wireValues  = map (day7 assignments) wireNames
-- in forM_ (zip wireNames wireValues) print
-- :}
-- ("d",72)
-- ("e",507)
-- ("f",492)
-- ("g",114)
-- ("h",65412)
-- ("i",65079)
-- ("x",123)
-- ("y",456)
day7 :: [Assignment] -> WireName -> Word16
day7 assignments name = eval env (lookupEnv' env name)
  where
    env :: Env
    env = mkEnv assignments

However, if we try it on the puzzle's larger circuit, the algorithm gets stuck! What happens is that many of the wires are used more than once, and yet are re-evaluated each time they are encountered. Consider the expression b AND c -> a. If operands b and c both end up depending on the same wire d, evaluating a will end up evaluating d's expression twice, and if a has to be evaluated twice, d will end up being evaluated four times. Since the number of evaluations doubles each time a new element is added to such a chain, it doesn't take many elements for the number of evaluations to become astronomical, causing our algorithm to get stuck re-evaluating the same expressions over and over.

Day 7, imperatively: caching

Clearly, we should cache the result of each wire in order to avoid evaluating the same expression more than once. Here is an imperative implementation of that idea: keep a map of the results computed so far, and each time we encounter a wire name, look inside the map to see if we already have a result for this wire. If we do, use it, otherwise recursively compute the answer and store it in the map.

type Cache = Map WireName Word16

lookupCache :: Cache -> WireName -> Maybe Word16
lookupCache = flip Map.lookup

lookupCache' :: Cache -> WireName -> Word16
lookupCache' = (Map.!)

eval :: Env -> Expr -> State Cache Word16
eval _   (Number   n) = return n
eval env (Wire  name) = do
    cache <- get
    case lookupCache cache name of
      Just x  -> return x
      Nothing -> do
          x <- eval env (lookupEnv' env name)
          modify (Map.insert name x)
          return x
eval env (AND    x y) = opAND    <$> eval env x <*> eval env y
eval env (OR     x y) = opOR     <$> eval env x <*> eval env y
eval env (LSHIFT x i) = opLSHIFT <$> eval env x <*> pure i
eval env (RSHIFT x i) = opRSHIFT <$> eval env x <*> pure i
eval env (NOT    x  ) = opNOT    <$> eval env x
Day 7, lazily: laziness-based caching and MemoTrie

Haskell has another way to cache results which is built into the language: its implementation of laziness.

In the previous days, I pointed out a few situations in which laziness improves the performance by skipping over the part of a pure computation whose result does not end up being used. If the result does end up being used, the computation must be performed. If the result ends up being used multiple times, the computation must also be performed, but only once, not multiple times. The way in which this is implemented is that the memory in which the result would normally be stored can point to either a thunk describing which computation needs to be forced to obtain the result, or it can point to the result itself if it has already been computed. In other words, laziness caches the results of computations so that each computation only has to be performed at most once.

Another aspect of laziness is that it allows us to define infinite data structures, by only constructing the portion of the data which ends up being needed, and also circular data structures, because by the time the structure loops back to the beginning, the beginning's thunk has already been expanded into a value.

-- |
-- >>> take 10 circular
-- [1,2,3,1,2,3,1,2,3,1]
circular :: [Int]
circular = 1 : 2 : 3 : circular

Here is a trickier example in which instead of directly looping back to the beginning, we examine the portion of the data structure which has been constructed so far and we produce a modified version.

-- |
-- >>> take 10 nats
-- [1,2,3,4,5,6,7,8,9,10]
nats :: [Int]
nats = 1 : map (+1) nats

Those two examples are both referring to earlier parts of the list, but it's also possible to refer to a later part of the list.

-- |
-- >>> backwards
-- [7,8,9,10]
backwards :: [Int]
backwards = [ (backwards !! 1) - 1
            , (backwards !! 2) - 1
            , (backwards !! 3) - 1
            , 10
            ]

Here is what happens while backwards is being printed. First, ((backwards !! 1) - 1)'s thunk is forced. This causes (backwards !! 2) - 1 to be forced, which in turn causes (backwards !! 3) - 1 to be forced as well. This yields the result 9, so the (backwards !! 3) - 1 thunk is replaced with the value 9, and similarly for 8 and 7. The first element 7 can finally be printed, and we move on to print the next elements, which have already been evaluated to 8, 9 and 10. As you can see, each thunk is only evaluated once, and if there are dependencies between the thunks, the dependencies are evaluated first.

I hope it is now clear how laziness can help us with today's puzzle: instead of writing an imperative computation to manually cache the results and traverse the dependencies, we can simply construct a data structure whose elements are defined in terms of each other. This way, evaluating any element of the data structure will automatically force its dependencies while caching the results.

day7 :: [Assignment] -> WireName -> Word16
day7 assignments name0 = lookupCache' cache name0
  where
    cache :: Cache
    cache = Map.fromList (map (second eval) assignments)
    
    eval :: Expr -> Word16
    eval (Number   n) = n
    eval (Wire  name) = lookupCache' cache name
    eval (AND    x y) = opAND    (eval x) (eval y)
    eval (OR     x y) = opOR     (eval x) (eval y)
    eval (LSHIFT x i) = opLSHIFT (eval x) i
    eval (RSHIFT x i) = opRSHIFT (eval x) i
    eval (NOT    x  ) = opNOT    (eval x)

Here I am constructing cache, a map from each wire name to its computed value, by applying eval to the corresponding expressions. eval is itself defined in terms of the cache, in which it looks up the values computed for the dependencies. We didn't have to write any special code to do so, but this cache lookup will either return immediately with the result if it has already been computed, or it will find and force a thunk, calling eval on the dependency and caching the result.

Another way to achieve the same result is to use a memoization library. Here I use MemoTrie to memoize the result of looking up and evaluating the expression corresponding to a wire name. This way, when evalExpr calls evalWire on a dependency, it will use the cached value if there is one. The implementation uses laziness under the hood.

import Data.MemoTrie

day7 :: [Assignment] -> WireName -> Word16
day7 assignments name0 = evalWire name0
  where
    env :: Env
    env = mkEnv assignments
    
    evalWire :: WireName -> Word16
    evalWire = memo (evalExpr . lookupEnv' env)
    
    evalExpr :: Expr -> Word16
    evalExpr (Number   n) = n
    evalExpr (Wire  name) = evalWire name
    evalExpr (AND    x y) = opAND    (evalExpr x) (evalExpr y)
    evalExpr (OR     x y) = opOR     (evalExpr x) (evalExpr y)
    evalExpr (LSHIFT x i) = opLSHIFT (evalExpr x) i
    evalExpr (RSHIFT x i) = opRSHIFT (evalExpr x) i
    evalExpr (NOT    x  ) = opNOT    (evalExpr x)

If you'd like to read more about using laziness for caching, I have written a post explaining when caches do and do not get reused between calls.

Day 7, meta-programmatically: Template Haskell

I know this post is getting quite long already, but I'd like to point out one last way in which the puzzle could be solved. Consider the following Haskell code:

d = opAND x y
e = opOR x y
f = opLSHIFT x 2
g = opRSHIFT y 2
h = opNOT x
i = opNOT y
x = 123
y = 456

Even though some of the above values are used before being defined, the thunk forcing mechanism makes sure that evaluating any of those values will first evaluate and cache its dependencies. So if we could generate similar Haskell code from the circuit description, we could efficiently obtain the value of any wire.

One way of generating code which is available in any language is to construct a string containing the code we want:

import Text.Printf

validName :: String -> String
validName "do" = "do'"
validName "id" = "id'"
validName "if" = "if'"
validName "in" = "in'"
validName name = name

exprS :: Expr -> String
exprS (Number   n) = show n
exprS (Wire  name) = validName name
exprS (AND    x y) = printf "opAND    %s %s" (exprS x) (exprS y)
exprS (OR     x y) = printf "opOR     %s %s" (exprS x) (exprS y)
exprS (LSHIFT x i) = printf "opLSHIFT %s %d" (exprS x) i
exprS (RSHIFT x i) = printf "opRSHIFT %s %d" (exprS x) i
exprS (NOT    x  ) = printf "opNOT    %s"    (exprS x)

-- |
-- >>> assignmentS ("g", RSHIFT (Wire "y") 2)
-- "g = opRSHIFT y 2"
assignmentS :: Assignment -> String
assignmentS (name, e) = printf "%s = %s" name (exprS e)

This works, but generating strings is quite error-prone, in the sense that the compiler is not going to prevent you from generating code which doesn't compile.

A more principled approach is to use Template Haskell. Instead of manipulating strings, we manipulate quasiquotations which fail at compile time if the quoted code does not parse.

{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH

validName :: String -> Name
validName "do" = mkName "do'"
validName "id" = mkName "id'"
validName "if" = mkName "if'"
validName "in" = mkName "in'"
validName name = mkName name

exprE :: Expr -> Q Exp
exprE (Number   n) = [| n |]
exprE (Wire  name) = varE (validName name)
exprE (AND    x y) = [| opAND    $(exprE x) $(exprE y) |]
exprE (OR     x y) = [| opOR     $(exprE x) $(exprE y) |]
exprE (LSHIFT x i) = [| opLSHIFT $(exprE x) i          |]
exprE (RSHIFT x i) = [| opRSHIFT $(exprE x) i          |]
exprE (NOT    x  ) = [| opNOT    $(exprE x)            |]

-- >>> let assignment = ("g", RSHIFT (Wire "y") 2)
-- >>> decls <- runQ $ assignmentD assignment
-- >>> ppr decls
-- g = opRSHIFT y 2
assignmentD :: Assignment -> Q [Dec]
assignmentD (name, e) = [d| $(var) = $(val) |]
  where
    var :: Q Pat
    var = varP (validName name)
    
    val :: Q Exp
    val = exprE e

For extra safety, there is also a variant of [| ... |] which detects type errors at compile time:

import Language.Haskell.TH.Syntax

exprE :: Expr -> Q (TExp Word16)
exprE (Number   n) = [|| n ||]
exprE (Wire  name) = unsafeTExpCoerce $ varE (validName name)
exprE (AND    x y) = [|| opAND    $$(exprE x) $$(exprE y) ||]
exprE (OR     x y) = [|| opOR     $$(exprE x) $$(exprE y) ||]
exprE (LSHIFT x i) = [|| opLSHIFT $$(exprE x) i           ||]
exprE (RSHIFT x i) = [|| opRSHIFT $$(exprE x) i           ||]
exprE (NOT    x  ) = [|| opNOT    $$(exprE x)             ||]

Since we're generating variable names dynamically from the wire names, Template Haskell cannot know at compile time whether those variables have the correct type, so we have to use unsafeTExpCoerce to tell it to trust us that this piece will work out.

To complete the puzzle, I write a small wrapper which loads the circuit description from a file and concatenates all the generated declarations:

circuit :: FilePath -> Q [Dec]
circuit filename = do
    Right assignments <- runIO
                       $ parseFromFile (many assignment) filename
    decls <- forM assignments assignmentD
    return (concat decls)

I can finally load this circuit into my main program (for technical reason, the definitions above must be in a different file from the code below) and access the variables it defines.

-- defines "a" and many other variables
$(circuit "input.txt")

day7 :: Word16
day7 = a
Navigation

Sunday, December 20, 2015

A whirlwind tour of Haskell, day 6

Day 6: precise types, arrays, and ST

This puzzle asks us to parse and execute a sequence of instructions. The instructions are represented as text strings, so in a dynamic language I would probably use regular expressions to determine which instruction I'm looking at, using capturing groups like the following to extract the instruction's parameters.

/^command1 ([0-9]+) ([0-9]+)$/

In Haskell, however, I prefer to define a data type describing the set of all possible instructions, like this:

data Rectangle = Rectangle (V2 Integer) (V2 Integer)
  deriving (Show, Eq)

data Operation = TurnOn | TurnOff | Toggle
  deriving (Show, Eq)

data Instruction = Instruction Operation Rectangle
  deriving (Show, Eq)

The above says that an Instruction consists of an Operation, which can either be TurnOn, TurnOff or Toggle, followed by a Rectangle consisting of two 2D coordinates (two opposite corners). I prefer this representation over a simple string because it is more precise, in the sense that the set of values of this type more closely ressembles the set of valid operations than the set of strings does. There are tons of strings such as "flubberdoodle" which do not represent a valid instruction at all, while with this precise representation, the worse I can do is a value like Instruction TurnOn (V2 0 1000) (V2 50 1050), which at least looks like an instruction, and is only invalid because those coordinates are outside the bounds of the grid specified by the puzzle.

The advantage of having a precise representation is in making sure that we handle all the possibilities. If I was implementing the puzzle's instructions using a function taking a string as input, I'd have to write something like this:

runInstruction :: String -> ...
runInstruction s
  | "turn on"  `isPrefixOf` s = ...
  | "turn off" `isPrefixOf` s = ...
  | "toggle"   `isPrefixOf` s = ...
  | otherwise                 = error "unrecognized instruction"

And then if a new instruction was added, it would be easy to forget to add a handler for it in runInstruction, especially if there were many other functions to update throughout the codebase. By using a more precise algebraic type, I can write runInstruction like this instead:

runInstruction :: Instruction -> ...
runInstruction (Instruction TurnOn  ...) = ...
runInstruction (Instruction TurnOff ...) = ...
runInstruction (Instruction Toggle  ...) = ...

And then if a new instruction gets added, I'll get a warning at compile-time instead of an "unrecognized instruction" error at runtime. Assuming you're compiling with warnings enabled, of course, which isn't the default with the .cabal file generated by cabal init. I always add the line ghc-options: -W -Wall to the end of the file it generates.

Anyway, the instructions are about flipping bits in a bit array, so let's talk about Haskell arrays. The array library defines many different kinds of arrays, and in this implementation I'll be using two different kinds, UArray (V2 Integer) Bool and STUArray s (V2 Integer) Bool.

import Data.Array.ST
import Data.Array.Unboxed

type Index = V2 Integer
type Grid     =   UArray   Index Bool
type STGrid s = STUArray s Index Bool

The Bool means that each cell of the array will contain a boolean, and the V2 Integer means that we'll be indexing into the array using 2D coordinates, so this is a 2D array. The U means "unboxed". Unboxed arrays are only defined for value types which can be tightly-packed; in our case for example, booleans can be efficiently packed as a sequence of bits.

The ST in STUArray comes from yet another monadic EDSL, called ST. If you were disappointed in Day 1 when I said that the State EDSL was limited to a single stateful variable, you'll be happy to hear that ST is a variant which allows you to allocate an arbitrary number of stateful references and to modify them in-place. This is also the EDSL we'll need to use in order to modify our array in-place.

The three operations requested by the puzzle are quite straightforward to implement: we simply read and write booleans to the array at the given index. The unboxed array implementation takes care of translating those boolean reads and writes into the corresponding bit-fiddling shifts and masks which will touch the correct bits.

import Control.Monad.ST

turnOn :: STGrid s -> Index -> ST s ()
turnOn g i = writeArray g i True

turnOff :: STGrid s -> Index -> ST s ()
turnOff g i = writeArray g i False

toggle :: STGrid s -> Index -> ST s ()
toggle g i = do
    b <- readArray g i
    writeArray g i (not b)

Each puzzle instruction requires executing one of our three operations on all the cells inside a particular rectangular area. This is straightforward as well, using the range method. This method comes from a type class named Ix, short for "index", because a type needs to have an Ix instance in order for its values to be used as indices into an array. The Ix instance for Integer, used for 1D arrays, has a range method which simply lists all the integers between two bounds. The Ix instance for V2 Integer, used for 2D arrays, has a range method which enumerates all the 2D coordinates between the corners of a rectangle, which is exactly what we want.

Since ST implements the Monad type class, we can use our trusty forM_ to execute our chosen instruction on every index in the resulting list of indices.

listIndices :: Rectangle -> [Index]
listIndices (Rectangle c1 c2) = range (c1,c2)

runInstruction :: STGrid s -> Instruction -> ST s ()
runInstruction g = go
  where
    go (Instruction TurnOn  r) = forM_ (listIndices r) (turnOn  g)
    go (Instruction TurnOff r) = forM_ (listIndices r) (turnOff g)
    go (Instruction Toggle  r) = forM_ (listIndices r) (toggle  g)

Now that we can run a single instruction, we can run the entire list of instructions in order to obtain the final light pattern. To do this, I allocate a new array of the dimensions described in the puzzle, I execute each of the instructions, and I returned a frozen copy of the STUArray. This converts the STUArray, which cannot outlive the ST computation in which it was created, into an immutable UArray, which can live outside of ST but can no longer be modified in-place.

runInstructions :: [Instruction] -> Grid
runInstructions instructions = runST $ do
    g <- newArray (V2 0 0, V2 999 999) False
    forM_ instructions (runInstruction g)
    freeze g

Finally, to solve the puzzle, I parse the instruction strings into a list of precisely-typed Instructions, I run those instructions to get a light pattern, I enumerate the bits, keep those which are True, and count how many there were.

day6 = parseInstructions
   >>> runInstructions
   >>> elems
   >>> filter id
   >>> length

I've omitted the code for parsing the instructions, it's an important topic but I'll keep it for later. I've also omitted Day 6.5 because it is too similar to Day 6.

Navigation