In the time leading up to ZuriHac 2024 earlier this year, I had been thinking about Piet a little. We ended up working on something else during the Hackathon, but this was still in the back of my mind.

Some parts of Piets design are utter genius (using areas for number literals, using hue/lightness as cycles). There are also things I don’t like, such as the limited amount of colors, the difficulty reusing code, and the lack of a way to extend it with new primitive operations. I suspect these are part of the reason nobody has yet tried to write, say, an RDBMS or a web browser in Piet.

Given the amount of attention going to programming languages in the functional programming community, I was quite surprised nobody had ever tried to do a functional variant of it (as far as I could find).

I wanted to create something based on Lambda Calculus. It forms a nice basis for a minimal specification, and I knew that while code would still be somewhat frustrating to write, there is the comforting thought of being able to reuse almost everything once it’s written.

You can see the full specification here.

After playing around with different designs this is what I landed on. The guiding principle was to search for a specification that was as simple as possible, while still covering lambda calculus extended with primitives that, you know, allow you to interact with computers.

One interesting aspect that I discovered (not invented) is that it’s actually somewhat more expressive than Lambda Calculus, since you can build Abstract Syntax Graphs (rather than just Trees). This is illustrated in the loop example above, which recurses without the need for a fixed-point combinator.

For the full specification and more examples take a look at the Turnstyle website and feel free to play around with the sources on GitHub.

Thanks to Francesco Mazzoli for useful feedback on the specification and website.

This blogpost is written in reproducible Literate Haskell, so we need some imports first.

{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveTraversable #-}
module Main where
import qualified Codec.Picture          as JP
import qualified Codec.Picture.Types    as JP
import           Control.Monad.ST       (runST)
import           Data.Bool              (bool)
import           Data.Foldable          (for_)
import           Data.List              (isSuffixOf, partition)
import           Data.List.NonEmpty     (NonEmpty (..))
import           System.Environment     (getArgs)
import           System.Random          (RandomGen, newStdGen)
import           System.Random.Stateful (randomM, runStateGen)
import           Text.Read              (readMaybe)

Introduction

Haskell is not my only interest — I have also been quite into photography for the past decade. Recently, I was considering moving some of the stuff I have on various social networks to a self-hosted solution.

Tumblr in particular has a fairly nice way to do photo sets, where these can be organised in rows and columns. I wanted to see if I could mimic this in a recursive way, where rows and columns can be subdivided further.

One important constraint is that is that we want to present each picture as the photographer envisioned it: concretely, we can scale it up or down (preserving the aspect ratio), but we can’t crop out parts.

Order is also important in photo essays, so we want the author to specify the photo collage in a declarative way by indicating if horizontal (H) or vertical (V) subdivision should be used, creating a tree. For example:

H img1.jpg
  (V img2.jpg
     (H img3.jpg
        img4.jpg))

The program should then determine the exact size and position of each image, so that we get a fully filled rectangle without any borders or filler:

We will use a technique called circular programming that builds on Haskell’s laziness to achieve this in an elegant way. These days, it is maybe more commonly referred to as the repmin problem. This was first described by Richard S. Bird in “Using circular programs to eliminate multiple traversals of data” in 1984, which predates Haskell!

data Tree a
  = Leaf a
  | Branch (Tree a) (Tree a)

repmin_2pass :: Ord a => Tree a -> Tree a
repmin_2pass t =
  let globalmin = findmin t in rep globalmin t
 where
  findmin (Leaf x)     = x
  findmin (Branch l r) = min (findmin l) (findmin r)

  rep x (Leaf _)     = Leaf x
  rep x (Branch l r) = Branch (rep x l) (rep x r)

repmin_1pass :: Ord a => Tree a -> Tree a
repmin_1pass t = t'
 where
  (t', globalmin) = repmin t

  repmin (Leaf   x)   = (Leaf globalmin, x)
  repmin (Branch l r) =
    (Branch l' r', min lmin rmin)
   where
    (l', lmin) = repmin l
    (r', rmin) = repmin r

Starting out with some types

We start out by giving an elegant algebraic definition for a collage:

data Collage a
  = Singleton  a
  | Horizontal (Collage a) (Collage a)
  | Vertical   (Collage a) (Collage a)
  deriving (Foldable, Functor, Show, Traversable)

We use a higher-order type, which allows us to work with collages of filepaths as well as actual images (among other things). deriving instructs the compiler to generate some boilerplate code for us. This allows us to concisely read all images using traverse:

readCollage
  :: Collage FilePath
  -> IO (Collage (JP.Image JP.PixelRGB8))
readCollage = traverse $ \path ->
  JP.readImage path >>=
  either fail (pure . JP.convertRGB8)

We use the JuicyPixels library to read and write images. The image type in this library can be a bit verbose since it is parameterised around the colour space.

During the layout pass, we don’t really care about this complexity. We only need the relative sizes of the images and not their content. We introduce a typeclass to do just that:

data Size = Sz
  { szWidth  :: Rational
  , szHeight :: Rational
  } deriving (Show)

class Sized a where
  -- | Retrieve the width and height of an image.
  -- Both numbers must be strictly positive.
  sizeOf :: a -> Size

We use the Rational type for width and height. We are only subdividing the 2D space, so we do not need irrational numbers, and having infinite precision is convenient.

The instance for the JuicyPixels image type is simple:

instance Sized (JP.Image p) where
  sizeOf img = Sz
    { szWidth  = fromIntegral $ JP.imageWidth  img
    , szHeight = fromIntegral $ JP.imageHeight img
    }

Laying out two images

If we look at the finished image, it may seem like a hard problem to find a configuration that fits all the images with a correct aspect ratio.

But we can use induction to arrive at a fairly straightforward solution. Given two images, it is always possible to put them beside or above each other by scaling them up or down to match them in height or width respectively. This creates a bigger image. We can then repeat this process until just one image is left.

However, this is quite a naive approach since we end up making way too many copies, and the repeated resizing could also result in a loss of resolution. We would like to compute the entire layout first, and then render everything in one go. Still, we can start by formalising what happens for two images and then work our way up.

We can represent the layout of an individual image by its position and size. We use simple (x, y) coordinates for the position and a scaling factor (relative to the original size of the image) for its size.

data Transform = Tr
  { trX     :: Rational
  , trY     :: Rational
  , trScale :: Rational
  } deriving (Show)

Armed with the Size and Transform types, we have enough to tackle the “mathy” bits.

Let’s look at the horizontal case first and write a function that computes a transform for both left and right images, as well as the size of the result.

horizontal :: Size -> Size -> (Transform, Transform, Size)
horizontal (Sz lw lh) (Sz rw rh) =

We want to place image l beside image r, producing a nicely filled rectangle. Intuitively, we should be matching the height of both images.

There are different ways to do this — we could shrink the taller image, enlarge the shorter image, or something in between. We make a choice to always shrink the taller image, as this doesn’t compromise the sharpness of the result.

  let height = min lh rh
      lscale = height / lh
      rscale = height / rh
      width  = lscale * lw + rscale * rw in

With the scale for both left and right images, we can compute the left and right transforms. The left image is simply placed at (0, 0) and we need to offset the right image depending on the (scaled) size of the left image.

  ( Tr 0             0 lscale
  , Tr (lscale * lw) 0 rscale
  , Sz width height
  )

Composing images vertically is similar, just matching the widths rather than the heights of the two images and moving the bottom image below the top one:

vertical :: Size -> Size -> (Transform, Transform, Size)
vertical (Sz tw th) (Sz bw bh) =
  let width  = min tw bw
      tscale = width / tw
      bscale = width / bw
      height = tscale * th + bscale * bh in
  ( Tr 0 0             tscale
  , Tr 0 (tscale * th) bscale
  , Sz width height
  )

Composing transformations

Now that we’ve solved the problem of combining two images and placing them, we can apply this to our tree of images. To this end, we need to compose multiple transformations.

Whenever we think about composing things in Haskell, it’s good to ask ourselves if what we’re trying to compose is a Monoid. A Monoid needs an identity element (mempty) and a Semigroup instance, the latter of which contains just an associative binary operator (<>).

The identity transform is just offsetting by 0 and scaling by 1:

instance Monoid Transform where
  mempty = Tr 0 0 1

Composing two transformations using <> requires a bit more thinking. In this case, a <> b means applying transformation a after transformation b, so we will need to apply the scale of b to all parts of a:

instance Semigroup Transform where
  Tr ax ay as <> Tr bx by bs =
    Tr (ax * bs + bx) (ay * bs + by) (as * bs)

Readers who are familiar with linear algebra may recognise the connection to a sort of restricted affine 2D transformation matrix.

Proving that the identity holds on mempty is simple so we will only do one side, namely a <> mempty == a.

Tr ax ay as <> mempty

-- Definition of mempy
= Tr ax ay as <> Tr 0 0 1

-- Definition of <>
= Tr (ax * 1 + 0) (ay * 1 + 0) (as * 1)

-- Cancellative property of 0 over +
-- Identity of 1 over *
= Tr ax ay as

Next, we want to prove that the <> operator is associative, meaning a <> (b <> c) == (a <> b) <> c.

Tr ax ay as <> (Tr bx by bs <> Tr cx cy cs)

-- Definition of <>
= Tr (ax * (bs * cs) + (bx * cs + cx))
     (ay * (bs * cs) + (by * cs + cy))
     (as * (bs * cs))

-- Associativity of * and +
= Tr (ax * bs * cs + bx * cs + cx)
     (ay * bs * cs + by * cs + cy)
     ((as * bs) * cs)

-- Distributivity of * over +
= Tr ((ax * bs + bx) * cs + cx)
     ((ay * bs + by) * cs + cy)
     ((as * bs) * cs)

-- Definition of <>
= (Tr ax ay as <> T b by bs) <> Tr cx cy cs

Now that we have a valid Monoid instance, we can use the higher-level <> and mempty concepts in our core layout algorithm, rather than worrying over details like (x, y) coordinates and scaling factors.

The lazy layout

Our main layoutCollage function takes the user-specified tree as input, and annotates each element with a Transform. In addition to that, we also produce the Size of the final image so we can allocate space for it.

layoutCollage
  :: Sized img
  => Collage img
  -> (Collage (img, Transform), Size)

All layoutCollage does is call layout — our circular program — with the identity transformation:

layoutCollage = layout mempty

layout takes the size and position of the current element as an argument, and determines the sizes and positions of a tree recursively.

There are some similarities with the algorithms present in browser engines, where a parent element will first lay out its children, and then use their properties to determine its own width.

However, we will use Haskell’s laziness to do this in a single top-down pass. We provide a declarative algorithm and we leave the decision about what to calculate when — more concretely, propagating the requested sizes of the children back up the tree before constructing the transformations — to the compiler!

layout
  :: Sized img
  => Transform
  -> Collage img
  -> (Collage (img, Transform), Size)

Placing a single image is easy, since we are receiving the transformation directly as an argument. We return the requested size — which is just the original size of the image. This is an important detail in making the laziness work here: if we tried to return the final size (including the passed in transformation) rather than the requested size, the computation would diverge (i.e. recurse infinitely).

layout trans (Singleton img) =
  (Singleton (img, trans), sizeOf img)

In the recursive case for horizontal composition, we call the horizontal helper we defined earlier with the left and right image sizes as arguments. This gives us both transformations, that we can then pass in as arguments to layout again – returning the left and right image sizes we pass in to the horizontal helper, forming our apparent circle.

layout trans (Horizontal l r) =
  (Horizontal l' r', size)
 where
  (l', lsize)            = layout (ltrans <> trans) l
  (r', rsize)            = layout (rtrans <> trans) r
  (ltrans, rtrans, size) = horizontal lsize rsize

The same happens for the vertical case:

layout trans (Vertical t b) =
  (Vertical t' b', size)
 where
  (t', tsize)            = layout (ttrans <> trans) t
  (b', bsize)            = layout (btrans <> trans) b
  (ttrans, btrans, size) = vertical tsize bsize

It’s worth thinking about why this works: the intuitive explanation is that we can “delay” the execution of the transformations until the very end of the computation, and then fill them in everywhere. This works since no other parts of the algorithm depend on the transformation, only on the requested sizes.

Conclusion

We’ve written a circular program! Although I was aware of repmin for a long time, it’s not a technique I’ve applied often. To me, it is quite interesting because, compared to repmin:

• it is easier to explain to a novice why this is useful;
• it is perhaps easier to understand due to the visual aspect; and
• it is an example outside of the realm of parsers and compilers.

The structure is also somewhat different; rather than having a circular step at the top-level function invocation, we have it at every step of the recursion.

Thanks to Francesco Mazzoli and Titouan Vervack reading a draft of this blogpost and suggesting improvements. And thanks to you for reading!

What follows below are a number of relatively small functions that take care of various tasks, included so this can function as a standalone program:

• Actually rendering the layout back to an image
• Parsing a collage description
• Generating random collages
• Putting together the CLI
• Resizing the result

Appendices

Rendering the result

Once we’ve determined the layout, we still need to apply it and draw all the images using the computed transformations. We use simple nearest-neighbour scaling since that is not the focus of this program, you could consider Lánczos interpolation in a real application.

render
  :: Foldable f
  => Size
  -> f (JP.Image JP.PixelRGB8, Transform)
  -> JP.Image JP.PixelRGB8
render (Sz width height) images = runST $ do
  canvas <- JP.createMutableImage (round width) (round height) black
  for_ images $ transform canvas
  JP.unsafeFreezeImage canvas
 where
  black = JP.PixelRGB8 0 0 0

  transform canvas (img, Tr dstX dstY dstS) =
    for_ [round dstX .. round (dstX + dstW) - 1] $ \outX ->
    for_ [round dstY .. round (dstY + dstH) - 1] $ \outY ->
      let inX = min (JP.imageWidth img - 1) $ round $
                fromIntegral (outX - round dstX) / dstS
          inY = min (JP.imageHeight img - 1) $ round $
                fromIntegral (outY - round dstY) / dstS in
      JP.writePixel canvas outX outY $ JP.pixelAt img inX inY
   where
    dstW = fromIntegral (JP.imageWidth img)  * dstS
    dstH = fromIntegral (JP.imageHeight img) * dstS

Parsing a collage description

We use a simple parser to allow the user to specify collages as a string, for example on the command line. This is a natural fit for polish notation as using parentheses in command line arguments is very awkward.

As an example, we want to parse the following arguments:

H img1.jpg V img2.jpg H img3.jpg img4.jpg

Into this tree:

(Horizontal "img1.jpg"
  (Vertical "img2.jpg")
  (Horizontal "img3.jpg" "img4.jpg"))

We don’t even need a parser library, we can just treat the arguments as a stack:

parseCollage :: [String] -> Maybe (Collage FilePath)
parseCollage args = do
  (tree, []) <- parseTree args
  pure tree
 where
  parseTree []             = Nothing
  parseTree ("H" : stack0) = do
    (x, stack1) <- parseTree stack0
    (y, stack2) <- parseTree stack1
    pure (Horizontal x y, stack2)
  parseTree ("V" : stack0) = do
    (x, stack1) <- parseTree stack0
    (y, stack2) <- parseTree stack1
    pure (Vertical x y, stack2)
  parseTree (x   : stack0) = Just (Singleton x, stack0)

Generating random collages

In order to test this program, I also added some functionality to generate random collages.

randomCollage :: RandomGen g => NonEmpty a -> g -> (Collage a, g)
randomCollage ne gen = runStateGen gen $ \g -> go g ne
 where

The utility rc picks a random constructor.

  rc g = bool Horizontal Vertical <$> randomM g

In our worker function, we keep one item on the side (x), and randomly decide if other items will go in the left or right subtree:

  go g (x :| xs) = do
    (lts, rts) <- partition snd <$>
      traverse (\y -> (,) y <$> randomM g) xs

Then, we look at the random partitioning we just created. If they’re both empty, the only thing we can do is create a singleton collage:

    case (map fst lts, map fst rts) of
      ([],       [])       -> pure $ Singleton x

If either of them is empty, we put x in the other partition to ensure we don’t create invalid empty trees:

      ((l : ls), [])       -> rc g <*> go g (l :| ls) <*> go g (x :| [])
      ([],       (r : rs)) -> rc g <*> go g (x :| []) <*> go g (r :| rs)

Otherwise, we decide at random which partition x goes into:

      ((l : ls), (r : rs)) -> do
        xLeft <- randomM g
        if xLeft
          then rc g <*> go g (x :| l : ls) <*> go g (r :| rs)
          else rc g <*> go g (l :| ls)     <*> go g (x :| r : rs)

Putting together the CLI

We support two modes of operation for our little CLI:

• Using a user-specified collage using the parser we wrote before.
• Generating a random collage from a number of images.

In both cases, we also take an output file as the first argument, so we know where we want to write the image to. We also take an optional -fit flag so we can resize the final image down to a requested size.

data Command = Command
  { cmdOut     :: FilePath
  , cmdFit     :: Maybe Int
  , cmdCollage :: CommandCollage
  }

data CommandCollage
  = User   (Collage FilePath)
  | Random (NonEmpty FilePath)
  deriving (Show)

There is some setup to parse the output and a -fit flag. The important bit happens in parseCommandCollage further down.

parseCommand :: [String] -> Maybe Command
parseCommand cmd = case cmd of
  [] -> Nothing
  ("-fit" : num : args) | Just n <- readMaybe num -> do
    cmd' <- parseCommand args
    pure cmd' {cmdFit = Just n}
  (o : args) -> Command o Nothing <$> parseCommandCollage args

We’ll use R for a random collage, and H/V will be parsed by parseCollage.

 where
  parseCommandCollage ("R" : x : xs) = Just $ Random (x :| xs)
  parseCommandCollage spec           = User <$> parseCollage spec

Time to put everything together in the main function. First, we do some parsing:

main :: IO ()
main = do
  args <- getArgs
  command <- maybe (fail "invalid command") pure $
    parseCommand args
  pathsCollage <- case cmdCollage command of
    User explicit -> pure explicit
    Random paths -> do
      gen <- newStdGen
      let (random, _) = randomCollage paths gen
      pure random

Followed by actually reading in all the images:

  imageCollage <- readCollage pathsCollage

This gives us the Collage (JP.Image JP.PixelRGB8). We can pass that to our layout function and write it to the output, after optionally applying our fit:

  let (result, box) = case cmdFit command of
        Nothing -> layoutCollage imageCollage
        Just f  -> fit f $ layoutCollage imageCollage
  write (cmdOut command) $ JP.ImageRGB8 $ render box result
 where
  write output
    | ".jpg" `isSuffixOf` output = JP.saveJpgImage 80 output
    | otherwise                  = JP.savePngImage output

Resizing the result

Most of the time I don’t want to host full-resolution pictures for web viewing. This is an addition I added later on to resize an image down to a requested “long edge” (i.e. a requested maximum width or height, whichever is bigger).

Interestingly I think this can also be done by having an additional parameter to layout, and using circular programming once again to link the initial transformation to the requested size. However, the core algorithm is harder to understand that way, so I left it as a separate utility:

fit
  :: Int
  -> (Collage (img, Transform), Size)
  -> (Collage (img, Transform), Size)
fit longEdge (collage, Sz w h)
  | long <= fromIntegral longEdge = (collage, Sz w h)
  | otherwise                     =
      (fmap (<> tr) <$> collage, Sz (w * scale) (h * scale))
 where
  long  = max w h
  scale = fromIntegral longEdge / long
  tr    = Tr 0 0 scale

Here a simple warmup exercise just to get an idea of how it works:

Let’s continue with iterate but do a real puzzle next. What Monad are we looking for?

How is e defined again?

let allows us to reuse code. This is very useful if you don’t have enough tokens to make a sensible program.

Here is the final puzzle – but how can we produce a string from a bunch of numbers?

Haskell evaluation powered by tryhaskell.org. UI powered by some messy JavaScript.

We playtested these puzzles with simple pieces of paper during the event. At the final presentation we played a web-based multiplayer version where each player controls only one token.

We actually found the single player to be more fun, and since we already had some client code I decided to clean it up a bit and make a single player version available here.

Thanks for playing!

{-# LANGUAGE BangPatterns #-}
module Main where

import Data.IORef (IORef)
import qualified Data.Map as Map
import qualified Data.IORef as IORef
import Control.Monad (replicateM, forM_, unless, forM)
import Data.List (sort, intercalate, foldl')
import System.Random (randomIO)
import System.IO.Unsafe (unsafePerformIO)

Haskell’s laziness allows you to do many cool things. I’ve talked about searching an infinite graph before. Another commonly mentioned example is finding the smallest N items in a list.

Because programmers are lazy as well, this is often defined as:

smallestN_lazy :: Ord a => Int -> [a] -> [a]
smallestN_lazy n = take n . sort

This happens regardless of the language of choice if we’re confident that the list will not be too large. It’s more important to be correct than it is to be fast.

However, in strict languages we’re really sorting the entire list before taking the first N items. We can implement this in Haskell by forcing the length of the sorted list.

smallestN_strict :: Ord a => Int -> [a] -> [a]
smallestN_strict n l0 = let l1 = sort l0 in length l1 `seq` take n l1

If you’re at least somewhat familiar with the concept of laziness, you may intuitively realize that the lazy version of smallestN is much better since it’ll only sort as far as it needs.

But how much better does it actually do, with Haskell’s default sort?

A better algorithm?

For the sake of the comparison, we can introduce a third algorithm, which does a slightly smarter thing by keeping a heap of the smallest elements it has seen so far. This code is far more complex than smallestN_lazy, so if it performs better, we should still ask ourselves if the additional complexity is worth it.

smallestN_smart :: Ord a => Int -> [a] -> [a]
smallestN_smart maxSize list = do
    (item, n) <- Map.toList heap
    replicate n item
  where
    -- A heap is a map of the item to how many times it occurs in
    -- the heap, like a frequency counter.  We also keep the current
    -- total count of the heap.
    heap = fst $ foldl' (\acc x -> insert x acc) (Map.empty, 0) list
    insert x (heap0, count)
        | count < maxSize = (Map.insertWith (+) x 1 heap0, count + 1)
        | otherwise = case Map.maxViewWithKey heap0 of
            Nothing -> (Map.insertWith (+) x 1 heap0, count + 1)
            Just ((y, yn), _) -> case compare x y of
                EQ -> (heap0, count)
                GT -> (heap0, count)
                LT ->
                    let heap1 = Map.insertWith (+) x 1 heap0 in
                    if yn > 1
                        then (Map.insert y (yn - 1) heap1, count)
                        else (Map.delete y heap1, count)

So, we get to the main trick I wanted to talk about: how do we benchmark this, and can we add unit tests to confirm these benchmark results in CI? Benchmark execution times are very fickle. Instruction counting is awesome but perhaps a little overkill.

Instead, we can just count the number of comparisons.

Counting comparisons

We can use a new type that holds a value and a number of ticks. We can increase the number of ticks, and also read the ticks that have occurred.

data Ticks a = Ticks {ref :: !(IORef Int), unTicks :: !a}

mkTicks :: a -> IO (Ticks a)
mkTicks x = Ticks <$> IORef.newIORef 0 <*> pure x

tick :: Ticks a -> IO ()
tick t = IORef.atomicModifyIORef' (ref t) $ \i -> (i + 1, ())

ticks :: Ticks a -> IO Int
ticks = IORef.readIORef . ref

smallestN has an Ord constraint, so if we want to count the number of comparisons we’ll want to do that for both == and compare.

instance Eq a => Eq (Ticks a) where
    (==) = tick2 (==)

instance Ord a => Ord (Ticks a) where
    compare = tick2 compare

The actual ticking code goes in tick2, which applies a binary operation and increases the counters of both arguments. We need unsafePerformIO for that but it’s fine since this lives only in our testing code and not our actual smallestN implementation.

tick2 :: (a -> a -> b) -> Ticks a -> Ticks a -> b
tick2 f t1 t2 = unsafePerformIO $ do
    tick t1
    tick t2
    pure $ f (unTicks t1) (unTicks t2)
{-# NOINLINE tick2 #-}

Results

Let’s add some benchmarking that prints an ad-hoc CSV:

main :: IO ()
main = do
    let listSize = 100000
        impls = [smallestN_strict, smallestN_lazy, smallestN_smart]
    forM_ [50, 100 .. 2000] $ \sampleSize -> do
        l <- replicateM listSize randomIO :: IO [Int]
        (nticks, results) <- fmap unzip $ forM impls $ \f -> do
            l1 <- traverse mkTicks l
            let !r1 = sum . map unTicks $ f sampleSize l1
            t1 <- sum <$> traverse ticks l1
            pure (t1, r1)
        unless (equal results) . fail $
            "Different results: " ++ show results
        putStrLn . intercalate "," . map show $ sampleSize : nticks

Plug that CSV into a spreadsheet and we get this graph. What conclusions can we draw?

Clearly, both the lazy version as well as the “smart” version are able to avoid a large number of comparisons. Let’s remove the strict version so we can zoom in.

What does this mean?

• If the sampleSize is small, the heap implementation does less comparions. This makes sense: even if treat sort as a black box, and don’t look at it’s implementation, we can assume that it is not optimally lazy; so it will always sort “a bit too much”.

• As sampleSize gets bigger, the insertion into the bigger and bigger heap starts to matter more and more and eventually the naive lazy implementation is faster!

• Laziness is awesome and take N . sort is absolutely the first implementation you should write, even if you replace it with a more efficient version later.

• Code where you count a number of calls is very easy to do in a test suite. It doesn’t pollute the application code if we can patch in counting through a typeclass (Ord in this case).

Can we say something about the complexity?

• The complexity of smallestN_smart is basically inserting into a heap listSize times. This gives us O(listSize * log(sampleSize)).

  That is of course the worst case complexity, which only occurs in the special case where we need to insert into the heap at each step. That’s only true when the list is sorted, so for a random list the average complexity will be a lot better.

• The complexity of smallestN_lazy is far harder to reason about. Intuitively, and with the information that Data.List.sort is a merge sort, I came to something like O(listSize * max(sampleSize, log(listSize))). I’m not sure if this is correct, and the case with a random list seems to be faster.

  I would be very interested in knowing the actual complexity of the lazy version, so if you have any insights, be sure to let me know!

  Update: Edward Kmett corrected me: the complexity of smallestN_lazy is actually O(listSize * min(sampleSize, listSize)), with O(listSize * min(sampleSize, log(listSize)) in expectation for a random list.

Thanks to Huw Campbell for pointing out a bug in the implementation of smallestN_smart – this is now fixed in the code above.

Appendix

Helper function: check if all elements in a list are equal.

equal :: Eq a => [a] -> Bool
equal (x : y : zs) = x == y && equal (y : zs)
equal _            = True

Unfortunately, there was a thick layer of clouds so we didn’t get the amazing panoramic views from the top. On the flip side, this really works well with black-and-white photography: the clouds add a lot of drama and character. This is a selection of six photographs.

Haskell is great building at DSLs – which are perhaps the ultimate form of slacking off at work. Rather than actually doing the work your manager tells you to, you can build DSLs to delegate this back to your manager so you can focus on finally writing up that GHC proposal for MultilinePostfixTypeOperators (which could have come in useful for this blogpost).

So, we’ll build a visual DSL that’s so simple even your manager can use it! This blogpost is a literate Haskell file so you can run it directly in GHCi. Note that some code is located in a second module because of compilation stage restrictions.

Let’s get started. We’ll need a few language extensions – not too much, just enough to guarantee job security for the forseeable future.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Visual where

And then some imports, not much going on here.

import qualified Codec.Picture as JP
import qualified Codec.Picture.Types as JP
import Control.Arrow
import Control.Category
import Control.Monad.ST (runST)
import Data.Char (isUpper)
import Data.Foldable (for_)
import Data.List (sort, partition)
import qualified Language.Haskell.TH as TH
import Prelude hiding (id, (.))

All Haskell tutorials that use some form of dependent typing seem to start with the HList type. So I suppose we’ll do that as well.

data HList (things :: [*]) where
  Nil  :: HList '[]
  Cons :: x -> HList xs -> HList (x ': xs)

I think HList is short for hype list. There’s a lot of hype around this because it allows you to put even more types in your types.

We’ll require two auxiliary functions for our hype list. Because of all the hype, they each require a type family in order for us to even express their types. The first one just takes the last element from a list.

hlast :: HList (thing ': things) -> Last (thing ': things)
hlast (Cons x Nil)         = x
hlast (Cons _ (Cons y zs)) = hlast (Cons y zs)

type family Last (l :: [*]) :: * where
  Last (x ': '[]) = x
  Last (x ': xs)  = Last xs

Readers may wonder if this is safe, since last is usually a partial function. Well, it turns out that partial functions are safe if you type them using partial type families. So one takeaway is that partial functions can just be fixed by adding more partial stuff on top. This explains things like Prelude.

Anyway, the second auxiliary function drops the last element from a list.

hinit :: HList (thing ': things) -> HList (Init (thing ': things))
hinit (Cons _ Nil)         = Nil
hinit (Cons x (Cons y zs)) = Cons x (hinit (Cons y zs))

type family Init (l :: [*]) :: [*] where
  Init (_ ': '[])     = '[]
  Init (x ': y ': zs) = x ': Init (y ': zs)

And that’s enough boilerplate! Let’s get right to it.

It’s always good to pretend that your DSL is built on solid foundations. As I alluded to in the title, we’ll pick Arrows. One reason for that is that they’re easier to explain to your manager than Applicative (stuff goes in, other stuff comes out, see? They’re like the coffee machine in the hallway). Secondly, they are less powerful than Monads and we prefer to keep that good stuff to ourselves.

Unfortunately, it seems like the Arrow module was contributed by an operator fetishism cult, and anyone who’s ever done non-trivial work with Arrows now has a weekly therapy session to talk about how &&& and *** hurt them.

This is not syntax we want anyone to use. Instead, we’ll, erm, slightly bend Haskell’s syntax to get something that is “much nicer” and “definitely not an abomination”.

We’ll build something that appeals to both Category Theorists (for street cred) and Corporate Managers (for our bonus). These two groups have many things in common. Apart from talking a lot about abstract nonsense and getting paid for it, both love drawing boxes and arrows.

Yeah, so I guess we can call this visual DSL a Diagram. The main drawback of arrows is that they can only have a single input and output. This leads to a lot of tuple abuse.

We’ll “fix” that by having extra ins and outs. We are wrapping an arbitrary Arrow, referred to as f in the signature:

data Diagram (ins :: [*]) (outs :: [*]) f a b where

We can create a diagram from a normal arrow, that’s easy.

  Diagram :: f a b -> Diagram '[] '[] f a b

And we can add another normal function at the back. No biggie.

  Then
    :: Diagram ins outs f a b -> f b c
    -> Diagram ins outs f a c

Of course, we need to be able to use our extra input and outputs. Output wraps an existing Diagram and redirects the second element of a tuple to the outs; and Input does it the other way around.

  Output
    :: Diagram ins outs f a (b, o)
    -> Diagram ins (o ': outs) f a b

  Input
    :: Diagram ins outs f a b
    -> Diagram (i ': ins) outs f a (b, i)

The hardest part is connecting two existing diagrams. This is really where the magic happens:

  Below
    :: Diagram ins1 outs1 f a b
    -> Diagram (Init (b ': outs1)) outs2 f (Last (b ': outs1)) c
    -> Diagram ins1 outs2 f a c

Is this correct? What does it even mean? The answer to both questions is: “I don’t know”. It typechecks, which is what really matters when you’re doing Haskell. And there’s something about ins matching outs in there, yeah.

Concerned readers of this blog may at this point be wondering why we used reasonable names for the constructors of Diagram rather than just operators.

Well, it’s only because it’s a GADT which makes this impossible. But fear not, we can claim our operators back. Shout out to Unicode’s Box-drawing characters: they provide various charaters with thick and thin lines. This lets us do an, uhm, super intuitive syntax where tuples are taken apart as extra inputs/outputs, or reified back into tuples.

(━►)   = Then
l ┭► r = Output l ━► r
l ┳► r = (l ━► arr (\x -> (x, x))) ┭► r
l ┶► r = Input l ━► r
l ╆► r = Output (Input l ━► arr (\x -> (x, x))) ━► r
l ┳ c  = l ┳► arr (const c)
l ┓ r  = Below l r
l ┧ r  = Input l ┓ r
l ┃ r  = Input l ━► arr snd ┓ r
infixl 5 ━►, ┳►, ┭►, ┶►, ╆►, ┳
infixr 4 ┓, ┧, ┃

Finally, while we’re at it, we’ll also include an operator to clearly indicate to our manager how our valuation will change if we adopt this DSL.

(📈) = Diagram

This lets us do the basics. If we start from regular Arrow syntax:

horribleExample01 =
  partition isUpper >>> reverse *** sort >>> uncurry mappend

We can now turn this into:

amazingExample01 =
 (📈) (partition isUpper)┭►reverse┓
 (📈)                   sort      ┶►(uncurry mappend)

The trick to decrypting these diagrams is that each line in the source code consists of an arrow where values flow from the left to the right; with possible extra inputs and ouputs in between. These lines are then composed using a few operators that use Below such as ┓ and ┧.

To improve readability even further, it should also be possible to add right-to-left and top-to-bottom operators. I asked my manager if they wanted these extra operators but they’ve been ignoring all my Slack messages since I showed them my original prototype. Probably just busy?

Anyway, there are other simple improvements we can make to the visual DSL first. Most Haskellers prefer nicely aligning things over producing working code, so it would be nice if we could draw longer lines like ━━━━┳━► rather than just ┳►. And any Haskeller worth their salt will tell you that this is where Template Haskell comes in.

Template Haskell gets a bad rep, but that’s only because it is mostly misused. Originally, it was designed to avoid copying and pasting a lot of code, which is exactly what we’ll do here. Nothing to be grossed out about.

extensions :: Maybe Char -> String -> Maybe Char -> [String]
extensions mbLeft operator mbRight =
  [operator] >>= maybe pure goR mbRight >>= maybe pure goL mbLeft
 where
  goL l op = [replicate n l ++ op | n <- [1 .. 19]]
  goR r op = [init op ++ replicate n r ++ [last op] | n <- [1 .. 19]]

industryStandardBoilerplate
  :: Maybe Char -> TH.Name -> Maybe Char -> TH.Q [TH.Dec]
industryStandardBoilerplate l name r = do
  sig <- TH.reify name >>= \case
    TH.VarI _ sig _ -> pure sig
    _               -> fail "no info"
  fixity <- TH.reifyFixity name >>= maybe (fail "no fixity") pure
  pure
    [ decl
    | name' <- fmap TH.mkName $ extensions l (TH.nameBase name) r
    , decl  <-
        [ TH.SigD name' sig
        , TH.FunD name' [TH.Clause [] (TH.NormalB (TH.VarE name)) []]
        , TH.InfixD fixity name'
        ]
    ]

We can then invoke this industry standard boilerplate to extend and copy/paste an operator like this:

$(industryStandardBoilerplate (Just '━') '(┭►) (Just '─'))

We’re now equipped to silence even the harshest syntax critics:

example02 =
  (📈) (partition isUpper)━┭─►(reverse)━┓
  (📈)                   (sort)─────────┶━►(uncurry mappend)

Beautiful! If you’ve ever wondered what people mean when they say functional programs “compose elegantly”, well, this is what they mean.

example03 =
  (📈) (+1)━┳━►(+1)━┓
  (📈)      (+1)━━━━╆━►add━┓
  (📈)              add────┶━►add
 where
  add = uncurry (+)

Type inference is excellent and running is easy. In GHCi:

*Main> :t example03
example04 :: Diagram '[] '[] (->) Integer Integer
*Main> run example03 1
12

Let’s look at a more complicated example.

lambda =
  (📈)  (id)━┭─►(subtract 0.5)━┳━━━━━━━━►(< 0)━━━━━━━━━━┓
  (📈)    (subtract 0.5)───────╆━►(add)━►(abs)━►(< 0.1)─┶━━━━━━━►(and)━━━━━━━┓
  (📈)                      (swap)━┭─►(* pi)━━►(sin)┳()                      ┃
  (📈)                           (* 2)──────────────┶━►(sub)━►(abs)━►(< 0.2)─┧
  (📈)                                                                      (or)━►(bool bg fg)
 where
  add = uncurry (+)
  sub = uncurry (-)
  and = uncurry (&&)
  or  = uncurry (||)
  fg  = JP.PixelRGB8 69  58  98
  bg  = JP.PixelRGB8 255 255 255

This renders everyone’s favorite greek letter:

Amazing! Math!

While the example diagrams in this post all use the pure function arrow ->, it is my duty as a Haskeller to note that it is really parametric in f or something. What this means is that thanks to this famous guy called Kleisli, you can immediately start using this with IO in production. Thanks for reading!

Update: CarlHedgren pointed out to me that a similar DSL is provided by Control.Arrow.Needle. However, that package uses Template Haskell to just parse the diagram. In this blogpost, the point of the exercise is to bend Haskell’s syntax and type system to achieve the notation.

Appendix 1: run implementation

The implementation of run uses a helper function that lets us convert a diagram back to a normal Arrow that uses HList to pass extra inputs and outputs:

fromDiagram
  :: Arrow f => Diagram ins outs f a b
  -> f (a, HList ins) (b, HList outs)

We can then have a specialized version for when there’s zero extra inputs and outputs. This great simplifies the type signatures and gives us a “normal” f a b:

run :: Arrow f => Diagram '[] '[] f a b -> f a b
run d = id &&& (arr (const Nil)) >>> fromDiagram d >>> arr fst

The definition for fromDiagram is as follows:

fromDiagram (Diagram f) = f *** arr (const Nil)
fromDiagram (Then l r) = fromDiagram l >>> first r
fromDiagram (Output l) =
  fromDiagram l >>> arr (\((x, y), things) -> (x, Cons y things))
fromDiagram (Input l) =
  arr (\(x, Cons a things) -> ((x, things), a)) >>>
  first (fromDiagram l) >>>
  arr (\((y, outs), a) -> ((y, a), outs))
fromDiagram (Below l r) =
  fromDiagram l >>>
  arr (\(x, outs) -> (hlast (Cons x outs), hinit (Cons x outs))) >>>
  fromDiagram r

Appendix 2: some type signatures

We wouldn’t want these to get in our way in the middle of the prose, but GHC complains if we don’t put them somewhere.

(┳►) :: Arrow f => Diagram ins outs f a b -> f b c
     -> Diagram ins (b ': outs) f a c
(┭►) :: Arrow f => Diagram ins outs f a (b, o) -> f b c
     -> Diagram ins (o ': outs) f a c
(┶►) :: Diagram ins outs f a b -> f (b, i) c
     -> Diagram (i ': ins) outs f a c
(╆►) :: Arrow f => Diagram ins outs f a b -> f (b, u) c
     -> Diagram (u ': ins) ((b, u) ': outs) f a c
(┧)  :: Diagram ins1 outs1 f a b
     -> Diagram (Init ((b, u) ': outs1)) outs2 f (Last ((b, u) ': outs1)) c
     -> Diagram (u ': ins1) outs2 f a c

Appendix 3: image rendering boilerplate

This uses a user-supplied Diagram to render an image.

image
  :: Int -> Int
  -> Diagram '[] '[] (->) (Double, Double) JP.PixelRGB8
  -> JP.Image JP.PixelRGB8
image w h diagram = runST $ do
  img <- JP.newMutableImage w h
  for_ [0 .. h - 1] $ \y ->
    for_ [0 .. w - 1] $ \x ->
      let x' = fromIntegral x / fromIntegral (w - 1)
          y' = fromIntegral y / fromIntegral (h - 1) in
      JP.writePixel img x y $ run diagram (x', y')
  JP.freezeImage img

You can use ReadyMedia without configuring it as a daemon. Just cd into any directory that has media files, and run this script:

Your television/phone/toaster should see the media server pop up within seconds.

Motivation

In this day and age, there are literally thousands of ways to get video on to your television screen, especially if you have a (somewhat) smart TV. If not, there is a plethora of devices that will let you stream from different sources.

For simply watching video files on my local disk, I used to just hook my laptop up to the television using a simple HDMI cable, which always worked – until the HDMI port on my television broke.

I don’t really want to get any of these devices, and I’m also not sure if I need a newer television that phones home.

In either case, most televisions that support any kind of networking will also support the DLNA protocol. For Linux, there’s ReadyMedia (formerly MiniDLNA), a relatively old project. But despite lacking some maintenance, it is pretty solid and reliable software.

By default, it runs as a daemon that stores a database of media. This makes it very cumbersome to use. The database gets out of sync easily when you move files around when it’s not running. The fact that it’s a daemon means that it could be running when you’re working from a coffee place. The daemon needs to be managed through a file in /etc/.

I don’t want to go through all that pain! I just want to be able to fire it up like you can get a quick HTTP server with just running python -m http.server in any directory. Then I can cd to whatever I want to watch and just run the thing and then kill it. I don’t care about keeping this media database, since scanning a single directory should be quick.

Well, it turns out you can do that fairly easily. Just drop the script I linked to at the top of this post in to your $PATH and you’re good to go.

At some point during ICFP2019 in Berlin, I came across a completely unrelated old paper by S. Lovejoy and B. B. Mandelbrot called “Fractal properties of rain, and a fractal model”.

While the model in the paper is primarily meant to model rainfall; the authors explain that it can also be used for rainclouds, since these two phenomena are naturally similarly-shaped. This means it can be used to generate pretty pictures!

While it looked cool at first, it turned out to be an extremely pointless and outdated way to generate pictures like this. But I wanted to write it up anyway since it is important to document failure as well as success: if you’ve found this blogpost searching for an implementation of this paper; well, you have found it, but it probably won’t help you. Here is the GitHub repository.

The good parts

I found this paper very intriguing because it promises a fractal model with a number of very attractive features:

• is extremely simple
• has easy to understand parameters
• is truly self-similar at different scales
• it has great lacunarity (I must admit I didn’t know this word before going through this paper)

Most excitingly, it’s possible to do a dimension-generic implementation! The code has examples in 2D as well as 3D (xy, time), but can be used without modifications for 4D (xyz, time) and beyond. Haskell’s type system allows capturing the dimension in a type parameter so we don’t need to sacrifice any type safety in the process.

For example, here the dimension-generic distance function I used with massiv:

distance :: M.Index ix => ix -> ix -> Distance
distance i j = Distance . sqrt .
    fromIntegral .  M.foldlIndex (+) 0 $
    M.liftIndex2 (\p s -> (p - s) * (p - s)) i j

Here is a 3D version:

The (really) bad parts

However, there must be a catch, right? If it has all these amazing properties, why is nobody using it? I didn’t see any existing implementations; and even though I had a very strong suspicion as to why that was the case, I set out to implement it during Munihac 2019.

As I was working on it, the answer quickly became apparent – the algorithm is so slow that its speed cannot even be considered a trade-off, its slowness really cancels out all advantages and then some! BitCoin may even be a better use of compute resources. The 30 second video clip I embedded earlier took 8 hours to render on a 16-core machine.

This was a bit of a bummer on two fronts: the second one being that I wanted to use this as a vehicle to learn some GPU programming; and it turned out to be a bad fit for GPU programming as well.

At a very high-level, the algorithm repeats the following steps many, many times:

1. At random, pick a position in (or near) the image.
2. Pick a size for your circular shape in a way that the probability of the size being larger than P is P⁻¹.
3. Draw the circular shape onto the image.

This sounds great for GPU programming; we could generate a large number of images and then just sum them together. However, the probability distribution from step 2 is problematic. Small (≤3x3) shapes are so common that it seems faster use a CPU (or, you know, 16 CPUs) and just draw that specific region onto a single image.

The paper proposes 3 shapes (which it calls “pulses”). It starts out with just drawing plain opaque circles with a hard edge. This causes some interesting but generally bad-looking edges:

It then switches to using circles with smoothed edges; which looks much better, we’re getting properly puffy clouds here:

Finally, the paper discusses drawing smoothed-out annuli, which dramatically changes the shapes of the clouds:

It’s mildly interesting that the annuli become hollow spheres in 3D.

Thanks to Alexey for massiv and a massive list of suggestions on my implementation!

However, I was talking with HVR about the Handle pattern, and the topic of argument order came up. This lead me to a neat use case for flip that I hadn’t seen before.

This blogpost should be approachable for beginners, but when you’re completely new to Haskell and some terms are confusing, I would recommend looking at the Type Classes or Learn You a Haskell materials first.

A few extensions are required to show some intermediary results, but – spoiler alert – they turn out to be unnecessary in the end:

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}

Currying and partial application

In Haskell, it is idiomatic to specify arguments that are unlikely to change in between function calls first.

For example, let’s look at the type of M.insertWith:

import qualified Data.Map as M

M.insertWith
  :: Ord k
  => (a -> a -> a)  -- ^ Merge values
  -> k              -- ^ Key to insert
  -> a              -- ^ Value to insert
  -> M.Map k a      -- ^ Map to insert into
  -> M.Map k a      -- ^ New map

This function allows us to insert an item into a map, or if it’s already there, merge it with an existing element. When we’re doing something related to counting items, we can “specialize” this function by partially applying it to obtain a function which adds a count:

increaseCount
  :: Ord k
  => k            -- ^ Key to increment
  -> Int          -- ^ Amount to increment
  -> M.Map k Int  -- ^ Current count
  -> M.Map k Int  -- ^ New count
increaseCount = M.insertWith (+)

And then we can do things like increaseCount "apples" 4 basket. The extremely succinct definition of increaseCount is only possible because functions in Haskell are always considered curried: every function takes just one element.

Sockets, Handles and more

However – there is a second idiomatic aspect of argument ordering. For imperative code, it is common to put the “object” or “handle” first. base itself is ripe with examples, and packages like network hold many more:

-- From System.IO
hSetBuffering
  :: Handle -> BufferMode -> IO ()
hGetBuf
  :: Handle -> Ptr a -> Int -> IO Int

-- From Control.Concurrent.Chan
writeChan
  :: Chan a -> a -> IO ()

-- From Control.Concurrent.MVar
modifyMVar
  :: MVar a -> (a -> IO (a, b)) -> IO b

This allows us to easily partially apply functions to a specific “object”, which comes in useful in where clauses:

writeSomeStuff :: Chan String -> IO ()
writeSomeStuff c = do
  write "Tuca"
  write "Bertie"
  write "Speckle"
 where
  write = writeChan c

In addition to that, it allows us to replace the type by a record of functions – as I went over in the handle pattern explanation.

Specializing top-level handle functions

However, we end up in a bit of a bind when we want to write succinct top-level definitions, like we did with increaseCount. Imagine we have a Handle to our database:

data Handle = Handle

Some mock utility types:

data Tier = Free | Premium
type MemberId = String

And a top-level function to change a member’s plan:

changePlan
  :: Handle
  -> Tier       -- ^ New plan
  -> String     -- ^ Comment
  -> MemberId   -- ^ Member to upgrade
  -> IO ()
changePlan = undefined

If we want a specialized version of this, we need to explicitly name and bind h, which sometimes feels a bit awkward:

halloweenPromo1 :: Handle -> MemberId -> IO ()
halloweenPromo1 h = changePlan h Premium "Halloween 2018 promo"

We sometimes would like to be able to write succinct definitions, such as:

halloweenPromo2 :: Handle -> MemberId -> IO ()
halloweenPromo2 = specialize changePlan Premium "Halloween 2018 promo"

But is this possible? And what would specialize look like?

Since this is a feature that relates to the type system, it is probably unsurprising that, yes, this is possible in Haskell. The concept can be represented as changing a function f to a function g:

class Specialize f g where
  specialize :: f -> g

Of course, a function can be converted to itself:

instance Specialize (a -> b) (a -> b) where
  specialize = id

Furthermore, if a Handle (a below) is the first argument, we can skip that it the converted version and first supply the second argument, namely b. This leads us to the following definition:

instance Specialize (a -> c) f => Specialize (a -> b -> c) (b -> f) where
  specialize f = \b -> specialize (\a -> f a b)

This is a somewhat acceptable solution, but it’s not great:

• type errors from incorrect usage of Specialize will be hard to read
• AllowAmbiguousInstances may required to defer instance resolution to the call site of specialize

Again, not show stoppers, but not pleasant either.

Flippin’ partial application

The unpleasantness around specialize is mainly caused by the fact that we need a typeclass to make this work for multiple arguments. Maybe using some sort of combinator can give us a simpler solution?

Because we’re lazy, let’s see if GHC has any ideas – we’ll use Typed holes to get a bit more info rather than doing the work ourselves:

halloweenPromo3 :: Handle -> MemberId -> IO ()
halloweenPromo3 =
  changePlan `_` Premium `_` "Halloween 2018 promo"

We get an error, and some suggestions:

posts/2019-10-15-flip-specialize.lhs:152:18: error:
 • Found hole:
     _ :: (Handle -> Tier -> String -> MemberId -> IO ()) -> Tier -> t0
   Where: ‘t0’ is an ambiguous type variable
 • In the expression: _
   In the first argument of ‘_’, namely ‘changePlan `_` Premium’
   In the expression:
     changePlan `_` Premium `_` "Halloween 2018 promo"
 • Relevant bindings include
     halloweenPromo3 :: Handle -> MemberId -> IO ()
       (bound at posts/2019-10-15-flip-specialize.lhs:151:3)
   Valid hole fits include
     flip :: forall a b c. (a -> b -> c) -> b -> a -> c
       with flip @Handle @Tier @(String -> MemberId -> IO ())
       (imported from ‘Prelude’ at posts/2019-10-15-flip-specialize.lhs:1:1
        (and originally defined in ‘GHC.Base’))
     seq :: forall a b. a -> b -> b
       with seq @(Handle -> Tier -> String -> MemberId -> IO ()) @Tier
       (imported from ‘Prelude’ at posts/2019-10-15-flip-specialize.lhs:1:1
        (and originally defined in ‘GHC.Prim’))
     const :: forall a b. a -> b -> a
       with const @(Handle -> Tier -> String -> MemberId -> IO ()) @Tier
       (imported from ‘Prelude’ at posts/2019-10-15-flip-specialize.lhs:1:1
        (and originally defined in ‘GHC.Base’))
 ...

Wait a minute! flip looks kind of like what we want: it’s type really converts a function to another function which “skips” the first argument. Is it possible that what we were looking for was really just… the basic function flip?

halloweenPromo4
  :: Handle -> MemberId -> IO ()
halloweenPromo4 =
  changePlan `flip` Premium `flip` "Halloween 2018 promo"

We can make the above pattern a bit cleaner by introducing a new operator:

(/$) :: (a -> b -> c) -> (b -> a -> c)
(/$) = flip

halloweenPromo5 :: Handle -> MemberId -> IO ()
halloweenPromo5 =
  changePlan /$ Premium /$ "Halloween 2018 promo"

Fascinating! I was aware of using flip in this way to skip a single argument (e.g. foldr (flip M.increaseCount 1)), but, in all the time I’ve been writing Haskell, I hadn’t realized this chained in a usable and nice way.

In a way, it comes down to reading the type signature of flip in two ways:

1. flip :: (a -> b -> c) -> (b -> a -> c)

   Convert a function to another function that has the two first arguments flipped. This is the way I am used to reading flip – and also what the name refers to.

2. flip :: (a -> b -> c) -> b -> (a -> c)

   Partially apply a function to the second argument. After supplying a second argument, we can once again supply a second argument, and so on – yielding an intuitive explanation of the chaining.

It’s also possible to define sibling operators //$, ///$, etc., to “skip” the first N arguments rather than just the first one in a composable way.

Update: Dan Dart pointed out to me that the sibling operators actually exist under the names of -$, --$, etc. in the composition-extra package.

Should I use this everywhere?

… probably not? While it is a mildly interesting trick, unless it becomes a real pain point for you, I see nothing wrong with just writing:

halloweenPromo6 :: Handle -> MemberId -> IO ()
halloweenPromo6 h = changePlan h Premium "Halloween 2018 promo"

I am one of the organizers of ZuriHac, and last year, we hand-rolled our own registration system for the event in Haskell. This blogpost explains why we decided to go this route, and we dip our toes into its design and implementation just a little bit.

I hope that the second part is especially useful to less experienced Haskellers, since it is a nice example of a small but useful standalone application. In fact, this was more or less an explicit side-purpose of the project: I worked on this together with Charles Till since he’s a nice human being and I like mentoring people in day-to-day practical Haskell code.

In theory, it should also be possible to reuse this system for other events – not too much of it is ZuriHac specific, and it’s all open source.

Why?

Before 2019, ZuriHac registration worked purely based on Google tools and manual labor:

• Google Forms for the registration form
• Google Groups to contact registrants
• Google Sheets to manage the registrants, waitlist, T-Shirt numbers, …

Apart from the fact that the manual labor wasn’t scaling above roughly 300 people, there were a number of practical issues with these tools. The biggest issue was managing the waiting list and cancellations.

You see, ZuriHac is a free event, which means that the barrier to signing up for it is (intentionally and with good reason!) extremely low. Unfortunately, this will always result in a significant amount of people who sign up for the event, but do not actually attend. We try compensating for that by overbooking and offering cancellations; but sometimes it turns out to be hard to get people to cancel as well – especially if it’s hard to reach them.

Google Groups is not great for the purpose we’re using it for: first of all, attendees actually need to go and accept the invitation to join the group. Secondly, do you need a Google Account to join? I still don’t know and have seen conflicting information over the years. Anyway, it’s all a bit ad-hoc and confusing.

So one of the goals for the new registration system (in addition to reducing work on our side) was to be able to track participant numbers better and improve communication. We wanted to work with an explicit confirmation that you’re attending the event; or with a downloadable ticket so that we could track how many people downloaded this ¹.

I looked into a few options (eventbrite, eventlama, and others…) but none of these ticked all the boxes: aside from being free (since we have limited budget). Some features that I wanted were:

• complete privacy for our attendees
• a custom “confirmation” workflow, or just being able to customize the registration flow in general
• and some sort of JSON or CSV export option

With these things in mind, I set out to solve this problem the same the way I usually solve problems: write some Haskell code.

How?

The ZuriHac Registration system (zureg) is a “serverless” application that runs on AWS. It was designed to fit almost entirely in the free tier of AWS; which is why I, for example, picked DynamoDB over a database that’s actually nice to use. We used Brendan Hay’s excellent and extensive amazonka libraries to talk to AWS.

The total cost of having this running for a year, including during ZuriHac itself, totaled up to 0.61 Swiss Francs so I would say that worked out well price wise!

There are two big parts to the application: a fat lambda ² function that provides a number of different endpoints, and a bunch of command line utilities that talk to the different services directly.

All these parts, however, are part of one monolithic codebase which makes it very easy to share code and ensure all behaviour is consistent – globally coherent as some would call it. One big “library” that has well-defined module boundaries and multiple lightweight “executables” is how I like to design applications in Haskell (and other languages).

Building and deploying

First, I’d like to go into how the project is built and compiled. It’s not something I’m proud of, but I do think it makes a good cookbook on how to do things the hard way.

The main hurdle is that we wanted want to run our Haskell code on Lambda, since this is much cheaper than using an EC2 instance: the server load is very bursty with long periods (days up to weeks) of complete inactivity.

I wrote a bunch of the zureg code before some Haskell-on-Lambda solutions popped up, so it is all done from scratch – and it’s surprisingly short. However, if I were to start a new project, I would probably use one of these frameworks:

• wai-lambda
• serverless-haskell
• aws-lambda-haskell-runtime

Converting zureg to use of these frameworks is something I woulld like to look into at some point, if I find the time. The advantage of doing things from scratch, however, is that it serves the educational purposes of this blogpost very well!

Our entire serverless framework is currently contained in a single 138-line file.

From a bird’s eye view:

1. We define a docker image that’s based on Amazon Linux – this ensures we’re using the same base operating system and system libraries as Lambda, so our binary will work there.

2. We compile our code inside a docker container and copy out the resulting executable to the host.

3. We zip this up together with a python script that just forwards requests to the Haskell process.

4. We upload this zip to S3 and our cloudformation takes care of setting up the rest of the infrastructure.

I think this current situation is still pretty manageable since the application is so small; but porting it to something nicer like Nix is definitely on the table.

The database

The data model is not too complex. We’re using an event sourcing approach: this means that our source of truth is really an append-only series of events rather than a traditional row in a database that we update. These events are stored as plain JSON, and we can define them in pure Haskell:

lib/Zureg/Model.hs

And then we just have a few handwritten functions in the database module:

lib/Zureg/Database.hs

This gives us a few things for free; most importantly if something goes wrong we can go in and check what events led the user to get into this invalid state.

This code is backed by the eventful and eventful-dynamodb libraries, in addition to some custom queries.

The lambda

While our admins can interact with the system using the CLI tooling, registrants interact with the system using the webapp. The web application is powered by a fat lambda.

Using this web app, registrants can do a few things:

• Register for the event (powered by a huge web 1.0 form using digestive-functors);
• View their ticket (including a QR code generated by qrcode;
• Confirm their registration;
• Cancel their registration.

In addition to these routes used by participants, there’s a route used for ticket scans – which we’ll talk about next.

The scanning

Now that we have participant tickets, we need some way to process them at the event itself.

scanner.js is a small JavaScript tool that does this for us. It uses the device’s webcam to scan QR codes – which is nice because this means we can use either phones, tablets or a laptop to scan tickets at the event, the device just needs a modern browser version. It’s built on top of jsQR.

The scanner intentionally doesn’t do much processing – it just displays a full-screen video of the webcam and searches for a QR code using an external library. Once we get a hit for a QR code, we poll the lambda again to retrieve some information (participant name, T-Shirt size) and overlay that on top of the video.

This is useful because now the people working at the registration desk can see, as demonstrated in the image above, that I registered too late and therefore should only pick up a T-Shirt on the second day.

What is next?

There is a lot of room for improvement, but the fact that it had zero technical issues during registration or the event makes me very happy. Off the top of my head, here are some TODOs for next years:

• We should have a CRON-style Lambda that handles the waiting list automation even further.
• It should be easier for attendees to update their information.

Other than that, there are some non-functional TODOs:

• Can we make the build/deploy a bit easier?
• Should we port zureg to use one of the existing Haskell-on-Lambda frameworks?
• I’m currently using somewhat fancy image scaling to get a sharp scaled up QR image, but this does not work if someone saves it on their phone – we should just do the scaling on the backend.

Any contributions in these areas are of course welcome!

Lastly, there’s the question of whether or not it makes sense for other events to use this. I discussed this briefly with Franz Thoma, one of the organizers of Munihac, who expressed similar gripes about evenbrite.

As it currently stands, zureg is not an off-the-shelf solution and requires some customization for your event – meaning it only really makes sense for Haskell events. On the other hand, there are a few people who prefer doing this over mucking around in settings dashboard that are hugely complicated but still do not provide the necessary customization.