Parsec is an industrial-strength parser library. I think one of its main advantages is that allows you generate really good error messages. However, this sometimes requires some non-obvious tricks. In this blogpost, I describe one of those. On the way, we illustrate how one can split up a Parsec parser into a lexer and an actual parser.

This blogpost assumes a little familiarity with Parsec or parser combinator libraries. There are tons of Parsec tutorials out there, such as this one.

**TL:DR:** Using `<?> ""`

allows you to erase error messages which in some cases can actually improve them.

This blogpost is written in literate Haskell so you should be able to just load it up in GHCi and play around with it (you can find the raw `.lhs`

file here).

```
> {-# LANGUAGE FlexibleContexts #-}
> import Control.Monad (void)
> import Text.Parsec
```

As an example, let’s build a simple Polish notation parser to parse expressions like:

`+ 2 (+ 1 4)`

We can model the expressions we want to parse like this:

```
> data Expr
> = Lit Int
> | Add Expr Expr
> deriving (Show)
```

Our parser is pretty straightforward – there are three cases: literals, additions, and expressions enclosed by parentheses.

```
> expr :: Stream s m Char => ParsecT s u m Expr
> expr = (<?> "expression") $
> (Lit <$> natural) <|>
> (plus >> Add <$> expr <*> expr) <|>
> (lparen *> expr <* rparen)
```

This uses the auxiliary parsers `natural`

, `plus`

, `lparen`

and `rparen`

. These are so-called *token* parsers. It is a common design pattern to split up a parser into a lexer (in this case, we call the collection of token parsers the lexer) and the actual parser ^{1}.

The idea behind that is that the lexer takes care of fiddling with whitespace, comments, and produces tokens – atomic symbols of the language such as `123`

, `+`

, `(`

, and `)`

. The parser can then focus on the actual logic: parsing expressions. It doesn’t need to care about details such as whitespace.

Now, onto the token parsers. These are typically placed in another module. First, let’s build some tools for dealing with whitespace and comments. Parsec already provides a parser to consume white space (`spaces`

), so let’s add one for a comment:

```
> -- | Consume a comment (from a '#' character to the end of the line) and
> -- return nothing.
> comment :: Stream s m Char => ParsecT s u m ()
> comment = (<?> "comment") $ char '#' >> void (manyTill anyChar endOfLine)
```

Using `comment`

and `spaces`

, we can build a parser that skips both:

```
> whitespace :: Stream s m Char => ParsecT s u m ()
> whitespace = do
> spaces
> optional $ comment >> whitespace
```

Now, let’s define a token parser a bit more clearly: a token parser is a parser which consumes an atomic symbol followed by an arbitrary amount of `whitespace`

.

This way, we can just use token parsers after one another in the parser and it is clear that the whitespace in between two tokens is consumed by the first token parser. Then, we only have to remember to strip whitespace from the beginning of the file when we write the top-level parser, like:

`whitespace *> expr`

Before we define our token parsers, let’s add a quick combinator which facilitates it:

```
> lexeme :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
> lexeme p = p <* whitespace
```

We can use `lexeme`

to define some simple tokens:

```
> plus, lparen, rparen :: Stream s m Char => ParsecT s u m Char
> plus = lexeme $ char '+'
> lparen = lexeme $ char '('
> rparen = lexeme $ char ')'
```

Followed by a slightly more complicated token:

```
> -- | Parse one or more digits as a decimal integer
> natural :: Stream s m Char => ParsecT s u m Int
> natural = (<?> "number") $ lexeme $ do
> x <- try digit
> xs <- many digit
> return $ read (x : xs)
```

That’s it! Now we have our parser. If we parse the following expression:

```
+ (+ 1 2)
(+ 3
# Four is a really cool number
4)
```

We get:

`Add (Add (Lit 1) (Lit 2)) (Add (Lit 3) (Lit 4))`

Looking good!

At last, we arrive at the point of this blogpost. Let’s try to parse the following expression:

```
+ (+ 1 2)
(- 2 3)
```

We get the following error:

```
unexpected "-"
expecting white space, comment or expression
```

The error message is correct but a bit verbose. Sure, there could be a comment or whitespace at that position, but the user is probably aware of that. The real issue is that the parser is expecting an expression.

In the Parsec documentation, there is no reference to how one can manipulate this message. However, when we take a closer look at the Parsec source code, it turns out that there is a way: using `<?>`

with the empty string `""`

.

I think treating the empty string as a special case is a bit un-Haskelly – `<?>`

would be more self-documenting if it took a `Maybe String`

as its second argument – but it is what it is.

`<?> ""`

is a bit confusing to read – it is not immediately clear what it does so let’s turn it into a named combinator for clarity:

```
> eraseExpected :: ParsecT s u m a -> ParsecT s u m a
> eraseExpected = (<?> "")
```

We can rewrite `whitespace`

using this combinator.

```
> whitespace' :: Stream s m Char => ParsecT s u m ()
> whitespace' = do
> skipMany $ eraseExpected space
> optional $ eraseExpected comment >> whitespace'
```

Notice that we had to inline the definition of spaces before erasing the error message. This is because `<?>`

only sets the error message if the parser fails *without* consuming any input. This means that:

`eraseExpected spaces`

Would not erase the error message if at least one space character is consumed. Hence, we use `skipMany $ eraseExpected space`

.

If we fix `lexeme`

to use the new `whitespace'`

, we get a much nicer error message (in the spirit of *less is more*):

```
unexpected "-"
expecting expression
```

Thanks to Alex Sayers for proofreading.

Traditionally, the lexer and parser are actually split into separate phases, where the lexer produces a

`Token`

datatype stream from the input`String`

. Parsec, however, also allows you to write both at the same time, which is what we do in this blogpost. Both approaches have advantages and disadvantages.↩

When writing some code recently, I came across a very interesting Applicative Functor. I wanted to write about it for two reasons:

It really shows the power of Applicative (compared to Monad). Applicative does not require access to previously computed results, which helps in this case, because it allows us to execute statements in whatever order is convenient.

I think it is novel, I was digging for a bit and could not find a similar Applicative in any Haskell code.

This blogpost is written in literate Haskell so you should be able to just load it up in GHCi and play around with it (you can find the raw `.lhs`

file here).

```
> {-# LANGUAGE BangPatterns #-}
> {-# LANGUAGE GADTs #-}
> {-# LANGUAGE ScopedTypeVariables #-}
```

```
> import Control.Applicative (Applicative (..), (<$>))
> import Control.Monad (forM, liftM, liftM2)
> import Control.Monad.State (State, runState, state)
> import Unsafe.Coerce (unsafeCoerce)
> import Data.List (sortBy)
> import qualified Data.Map as M
> import Data.Ord (comparing)
> import qualified Data.OrdPSQ as PSQ
> import Data.Traversable (traverse)
> import qualified Data.Vector as V
> import GHC.Exts (Any)
```

In our example, we will be modeling a dessert restaurant.

`> type Dessert = String`

We keep the inventory of our restaurant simply as a list. The important invariant here is that the inventory is always ordered from cheapest to most expensive.

`> type Inventory = [Dessert]`

```
> defaultInventory :: Inventory
> defaultInventory =
> [ "Pancake"
> , "Apple Pie"
> , "Apple Pie"
> , "Tiramisu"
> ]
```

Whenever a client wants to order something, they have two options:

- Request a specific dessert;
- Just get the cheapest one we have available.

In the first case, they will not get served anything if the specific dessert is out of stock. In the second case, they will only miss out on a dessert when our inventory is completely empty.

```
> data Request
> = RequestSpecificDessert Dessert
> | RequestCheapestDessert
> deriving (Show)
```

Let’s implement the logic for serving a request. We use `State Inventory`

to keep track of what’s available.

`> doRequest :: Request -> State Inventory (Maybe Dessert)`

For `RequestCheapestDessert`

, we make use of the fact that our inventory is sorted by price. This means the head of the list is the cheapest dessert, so we serve that and put the tail of the list (`xs`

) back.

We can do that conveniently using the `state`

function, which allows us to modify the state and compute a result at the same time:

`state :: (s -> (a, s)) -> State s a`

The implementation becomes:

```
> doRequest RequestCheapestDessert =
> state $ \inventory -> case inventory of
> [] -> (Nothing, [])
> (dessert : xs) -> (Just dessert, xs)
```

In case the client wants a specific dessert, we use `break`

to take out the requested item from the inventory list.

```
> doRequest (RequestSpecificDessert requested) =
> state $ \inventory -> case break (== requested) inventory of
> (xs, dessert : ys) -> (Just dessert, xs ++ ys)
> (xs, []) -> (Nothing, xs)
```

Let’s check if this works:

```
*Main> runState (doRequest RequestCheapestDessert) defaultInventory
(Just "Pancake",["Apple Pie","Apple Pie","Tiramisu"])
*Main> runState
(doRequest (RequestSpecificDessert "Apple Pie")) defaultInventory
(Just "Apple Pie",["Pancake","Apple Pie","Tiramisu"])
```

Looking good so far!

Because our restaurant wants to make as much money as possible, we choose to first serve the people who order a specific dessert. In order to do that, we have a ‘Priority’ type and each kind of request maps to a priority. Lower numbers means higher priority.

`> type Priority = Int`

```
> requestPriority :: Request -> Priority
> requestPriority (RequestSpecificDessert _) = 0
> requestPriority RequestCheapestDessert = 1
```

Now let’s see what happens when a bunch of friends visit our restaurant.

```
> friendsRequests :: [Request]
> friendsRequests =
> [ RequestCheapestDessert
> , RequestSpecificDessert "Apple Pie"
> , RequestCheapestDessert
> , RequestSpecificDessert "Pancake"
> , RequestSpecificDessert "Crème brûlée"
> ]
```

Easy: we first sort the requests by priority, and then we apply `doRequest`

on every `Request`

. We keep the requests so we know which `Dessert`

corresponds to which `Request`

.

```
> doRequests :: [Request] -> State Inventory [(Request, Maybe Dessert)]
> doRequests requests =
> forM (sortBy (comparing requestPriority) requests) $
> \req -> (,) req <$> doRequest req
```

Let’s run this for our example to see if it worked and if we got the priorities right:

```
*Main> runState (doRequests friendsRequests) defaultInventory
( [ (RequestSpecificDessert "Apple Pie", Just "Apple Pie")
, (RequestSpecificDessert "Pancake", Just "Pancake")
, (RequestSpecificDessert "Crème brûlée", Nothing)
, (RequestCheapestDessert, Just "Apple Pie")
, (RequestCheapestDessert, Just "Tiramisu")
]
, []
)
```

Works great! However, it gets trickier. What if, instead of just a list, we have something with a bit more structure:

```
> data Family a = Family
> { familyParent1 :: a
> , familyParent2 :: a
> , familyChildren :: V.Vector a
> } deriving (Show)
```

And we want to implement:

```
> doFamilyRequests
> :: Family Request -> State Inventory (Family (Maybe Dessert))
> doFamilyRequests = error "Implement me"
```

How do we go about that? Instead of just sorting by priority, we need to tag which request belongs to which parent or child, then sort them, and… it gets messy – especially if the problem becomes more complicated. Imagine, for example, that children get given a bit more priority. It would be cool if we could *separate* the evaluation order (priority) from our actual logic.

Fortunately, there is an Applicative Functor which solves exactly this problem.

The `Prio`

Applicative has three type parameters:

`p`

: The priority type, typically something like`Int`

or`Double`

;`m`

: The Monad we are annotating with priorities, for example`State Inventory`

;`a`

: Our result type.

We use a GADT which mirrors the interface of Applicative, and one additional constructor, which holds a monadic action together with its priority ^{1}.

```
> data Prio p m a where
> Pure :: a -> Prio p m a
> App :: Prio p m (a -> b) -> Prio p m a -> Prio p m b
```

`> Prio :: p -> m a -> Prio p m a`

For reference, here is the interface of Applicative again:

```
class Functor f => Applicative f where
pure :: a -> f a
(<*>) :: f (a -> b) -> f a -> f b
```

We can define a functor instance in terms of Applicative:

```
> instance Functor (Prio p m) where
> fmap f = App (Pure f)
```

And we can use the constructors to implement the Applicative instance:

```
> instance Applicative (Prio p m) where
> pure = Pure
> (<*>) = App
```

Now, we probably want to hide the actual constructors from the users and just provide a simple interface. Our interface consists of three functions:

`prio`

annotates a monadic action with a priority;`modifyPrio`

modifies the priorities in a`Prio`

value;`runPrio`

evaluates the`Prio`

to the base Monad.

The implementation of `prio`

is straightforward:

```
> prio :: p -> m a -> Prio p m a
> prio = Prio
```

A simple implementation of `modifyPrio`

walks through the tree and modifies priorities (`Prio`

nodes) as it encounters them ^{2}.

```
> modifyPrio :: forall p m a. (p -> p) -> Prio p m a -> Prio p m a
> modifyPrio f = go
> where
> go :: forall b. Prio p m b -> Prio p m b
> go (Pure x) = Pure x
> go (App x y) = App (go x) (go y)
> go (Prio p x) = Prio (f p) x
```

`runPrio`

also has a simple implementation: we find the minimal priority, and then evaluate all actions having this priority. When no priorities are left, we can use `unsafeEvaluate`

to evaluate the whole tree ^{3}.

```
> runPrio :: (Monad m, Ord p) => Prio p m a -> m a
> runPrio os = case findMinimalPriority os of
> Just p -> evaluatePriority p os >>= runPrio
> Nothing -> return $ unsafeEvaluate os
```

The three auxiliary functions used here `findMinimalPriority`

, `evaluatePriority`

and `unsafeEvaluate`

should be hidden from the user-facing API (except perhaps `findMinimalPriority`

). Let’s look at how these functions are implemented next.

`findMinimalPriority`

simply goes through the `Prio`

value and returns the minimal priority.

```
> findMinimalPriority
> :: forall p m a. (Monad m, Ord p)
> => Prio p m a -> Maybe p
> findMinimalPriority = go Nothing
> where
> go :: forall b. Maybe p -> Prio p m b -> Maybe p
> go !acc (Pure _) = acc
> go !acc (App x y) = go (go acc x) y
> go !Nothing (Prio p _) = Just p
> go !(Just !p0) (Prio p _) = Just (min p0 p)
```

`evaluatePriority`

evaluates all nodes with a priority equal or less than the given priority. We do so by replacing this `Prio`

constructor by a `Pure`

constructor.

```
> evaluatePriority
> :: forall p m a. (Monad m, Ord p)
> => p -> Prio p m a -> m (Prio p m a)
> evaluatePriority p0 = go
> where
> go :: forall b. Prio p m b -> m (Prio p m b)
> go (Pure x) = return (Pure x)
> go (App x y) = liftM2 App (go x) (go y)
> go (Prio p f)
> | p <= p0 = liftM Pure f
> | otherwise = return (Prio p f)
```

After we have recursively called `findMinimalPriority`

and `evaluatePriority`

until all the `Prio`

nodes are gone, we can call `unsafeEvaluate`

to get our actual value out.

```
> unsafeEvaluate :: Prio p m a -> a
> unsafeEvaluate (Pure x) = x
> unsafeEvaluate (App x y) = (unsafeEvaluate x) (unsafeEvaluate y)
> unsafeEvaluate (Prio _ _) = error
> "unsafeEvaluate: internal error: some steps still unevaluated"
```

We can now try this out. Remember the type of `doRequest`

:

`doRequest :: Request -> State Inventory (Maybe Dessert)`

Let’s add a variant which uses the priority of the `Request`

:

```
> prioRequest :: Request -> Prio Priority (State Inventory) (Maybe Dessert)
> prioRequest req = prio (requestPriority req) (doRequest req)
```

And for the whole family:

```
> prioFamilyRequests
> :: Family Request
> -> Prio Priority (State Inventory) (Family (Maybe Dessert))
> prioFamilyRequests family = Family
> <$> prioRequest (familyParent1 family)
> <*> prioRequest (familyParent2 family)
> <*> (modifyPrio (\x -> x - 1) $
> traverse prioRequest (familyChildren family))
```

Ain’t that clean code. Let’s test it out:

```
> familyRequest :: Family Request
> familyRequest = Family
> { familyParent1 = RequestCheapestDessert
> , familyParent2 = RequestSpecificDessert "Apple Pie"
> , familyChildren = V.fromList
> [ RequestCheapestDessert
> , RequestSpecificDessert "Pancake"
> , RequestSpecificDessert "Crème brûlée"
> ]
> }
```

```
*Main> runState (runPrio $ prioFamilyRequests familyRequest)
defaultInventory
( Family
{ familyParent1 = Just "Tiramisu"
, familyParent2 = Just "Apple Pie"
, familyChildren = fromList
[ Just "Apple Pie"
, Just "Pancake"
, Nothing
]
}
, []
)
```

Correct!

`Prio`

is an interesting Applicative. I particularly like the fact that it works for every Monad (although it doesn’t make sense for some Monads such as `Reader`

).

Use cases are rare. I’ve only encountered one and I could also have implemented it in a different way (although this feels a lot cleaner). However, I think a really important point about it is that it really illustrates the difference between Applicative and Monad very well.

Thanks to Alex Sayers, Jared Tobin and Maciej Wos for proofreading and discussions.

I have been requested to include the code for a faster `runPrio`

, so here it is. As you might expect, it is not as clean as the original one.

The code runs in roughly three steps:

Build a queue which sorts all the elements by priority. In addition to the priority, we have an

`Int`

key per`Prio`

node, determined by position.Evaluate this queue in the arbitrary Monad

`m`

. As result we now get a`Map`

which maps this`Int`

key to the value (of type`Any`

).Run through the original

`Prio`

again, and whenever we encounter a`Prio`

node, we use the`Int`

key to lookup and`unsafeCoerce`

the evaluated value from the`Map`

.

```
> fastRunPrio :: forall p m a. (Monad m, Ord p) => Prio p m a -> m a
> fastRunPrio prio0 = do
> let (queue, _) = buildQueue 0 prio0 PSQ.empty
> m <- evaluateQueue queue M.empty
> let (x, _) = evalPrio m 0 prio0
> return x
> where
```

The three steps are implemented in three auxiliary methods, which you can find here:

```
> buildQueue
> :: forall b.
> Int
> -> Prio p m b
> -> PSQ.OrdPSQ Int p (m Any)
> -> (PSQ.OrdPSQ Int p (m Any), Int)
> buildQueue !i (Pure _) !acc = (acc, i)
> buildQueue !i (App x y) !acc =
> let (acc', i') = buildQueue i x acc in buildQueue i' y acc'
> buildQueue !i (Prio p mx) !acc =
> (PSQ.insert i p (liftM unsafeCoerce mx) acc, i + 1)
>
> evaluateQueue
> :: PSQ.OrdPSQ Int p (m Any)
> -> M.Map Int Any
> -> m (M.Map Int Any)
> evaluateQueue q !acc = case PSQ.minView q of
> Nothing -> return acc
> Just (k, _, mx, q') -> do
> x <- mx
> evaluateQueue q' (M.insert k x acc)
>
> evalPrio
> :: forall b.
> M.Map Int Any
> -> Int
> -> Prio p m b
> -> (b, Int)
> evalPrio m !i (Pure x) = (x, i)
> evalPrio m !i (App x y) =
> let (x', i') = evalPrio m i x
> (y', i'') = evalPrio m i' y
> in (x' y', i'')
> evalPrio m !i (Prio p mx) =
> (unsafeCoerce (m M.! i), i + 1)
```

It could also be implemented on top of the Free Applicative, but I have decided against that to keep this blogpost as simple as possible.↩

A faster (but less concise) implementation would be to add a

`ModifyPrio`

constructor, and evaluate all of these at once, so we only have to go through the tree once.↩This implementation is very slow (quadratic in terms of the number of nodes in the

`Prio`

“tree”). I have found a faster way to implement this, but it is again less concise and requires the use of`unsafeCoerce`

, so it is omitted from this blogpost.**Update**: I have included this method in the Appendix.↩

```
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> import Control.Applicative (Applicative (..))
> import Data.Monoid (Monoid, (<>))
```

For the last month or, I have been working as a contractor for Luminal. I am helping them implement Fugue, and more specifically Ludwig – a compiler a for statically typed declarative configuration language. This is one of the most interesting projects I have worked on so far – writing a compiler is really fun. While implementing some parts of this compiler, I came across an interesting problem.

In particular, a typeclass instance seemed to adhere to both the Monad and Applicative laws, but with differing behaviour – which felt a bit fishy. I started a discussion on Twitter understand it better, and these are my thoughts on the matter.

Suppose we’re writing a typechecker. We have to do a number of things:

- Parse the program to get a list of user-defined types.
- Typecheck each expression.
- A bunch of other things, but for the purpose of this post we’re going to leave it at that.

Now, any of these steps could fail, and we’d like to log the reason for failure. Clearly this is a case for something like `Either`

! Let’s define ourselves an appropriate datatype.

```
> data Check e a
> = Failed e
> | Ok a
> deriving (Eq, Show)
```

We can write a straightforward Functor instance:

```
> instance Functor (Check e) where
> fmap _ (Failed e) = Failed e
> fmap f (Ok x) = Ok (f x)
```

The Monad instance is also very obvious:

```
> instance Monad (Check e) where
> return x = Ok x
>
> Failed e >>= _ = Failed e
> Ok x >>= f = f x
```

However, the Applicative instance is not that obvious – we seem to have a choice.

But first, lets take a step back and stub out our compiler a bit more, so that we have some more context. Imagine we have the following types in our compiler:

```
data Type = ...
data Expr = ...
data Program = ...
type TypeScope = [Type]
```

And our code looks like this:

```
> findDefinedTypes1 :: Program -> Check String TypeScope
> findDefinedTypes1 _ = Ok [] -- Assume we can't define types for now.
```

```
> typeCheck1 :: TypeScope -> Expr -> Check String Type
> typeCheck1 _ e = Failed $ "Could not typecheck: " ++ show e
```

```
> compiler1 :: Check String ()
> compiler1 = do
> scope <- findDefinedTypes1 program1
> typeCheck1 scope expr1 -- False == 3
> typeCheck1 scope expr2 -- [1, 'a']
> return ()
```

On executing `compiler1`

, we get the following error:

```
*Main> compiler1
Failed "Could not typecheck: False == 3"
```

Which is correct, but using a compiler entirely written in this fashion would be annoying. `Check`

, like `Either`

, short-circuits on the first error it encounters. This means we would compile our program, fix one error, compile, fix the next error, compile, and so on.

It would be much nicer if users were to see multiple error messages at once.

Of course, this is not always possible. On one hand, if `findDefinedTypes1`

throws an error, we cannot possibly call `typeCheck1`

, since we do not have a `TypeScope`

.

On the other hand, if `findDefinedTypes1`

succeeds, shouldn’t it be possible to collect error messages from both `typeCheck1 scope expr1`

*and* `typeCheck1 scope expr2`

?

It turns out this is possible, precisely because the second call to `typeCheck1`

does not depend on the result of the first call – so we can execute them in parallel, if you will. And that is precisely the difference in expressive power between Monad and Applicative: Monadic `>>=`

provides access to previously computed results, where Applicative `<*>`

does not. Let’s *(ab?)*use this to our advantage.

Cleverly, we put together following instance:

```
> instance Monoid e => Applicative (Check e) where
> pure x = Ok x
>
> Ok f <*> Ok x = Ok (f x)
> Ok _ <*> Failed e = Failed e
> Failed e <*> Ok _ = Failed e
> Failed e1 <*> Failed e2 = Failed (e1 <> e2)
```

Using this instance we can effectively *collect* error messages. We need to change our code a bit to support a *collection* of error messages, so let’s use `[String]`

instead of `String`

since a list is a Monoid.

```
> findDefinedTypes2 :: Program -> Check [String] TypeScope
> findDefinedTypes2 _ = Ok [] -- Assume we can't define types for now.
```

```
> typeCheck2 :: TypeScope -> Expr -> Check [String] Type
> typeCheck2 _ e = Failed ["Could not typecheck: " ++ show e]
```

```
> compiler2 :: Check [String] ()
> compiler2 = do
> scope <- findDefinedTypes2 program1
> typeCheck2 scope expr1 *> typeCheck2 scope expr2
> return ()
```

Note that `*>`

is the Applicative equivalent of the Monadic `>>`

.

Now, every error is represented by a *list* of error messages (typically a singleton such as in `typeCheck2`

), and the Applicative `<*>`

combines error messages. If we execute `compiler2`

, we get:

```
*Main> compiler2
Failed ["Could not typecheck: False == 3",
"Could not typecheck: [1, 'a']"]
```

Success! But is that all there is to it?

The problem is that we have created a situation where `<*>`

is not equal to `ap`

^{1}. After researching this for a while, it seems that `<*> = ap`

is not a verbatim rule. However, most arguments suggest it should be the case – even the name.

This is important for refactoring, for example. Quite a few Haskell programmers (including myself) would refactor:

```
do b <- bar
q <- qux
return (Foo b q)
```

Into:

`Foo <$> bar <*> qux`

Without putting too much thought in it, just assuming it does the same thing.

In our case, they are clearly *similar*, but not *equal* – we would get only one error instead of collecting error messages. One could argue that this is *close enough*, but when one uses that argument too frequently, you might just end up with something like PHP.

The problem becomes more clear in the following fragment:

```
checkForCyclicImports modules >>
compileAll modules
```

Which has completely different behaviour from this fragment:

```
checkForCyclicImports modules *>
compileAll modules
```

The latter will get stuck in some sort of infinite recursion, while the former will not. This is not a subtle difference anymore. While the problem is easy to spot here (`>>`

vs. `*>`

), this is not always the case:

`forEveryImport_ :: Monad m => Module -> (Import -> m ()) -> m ()`

Ever since AMP, it is impossible to tell whether this will do a `forM_`

or a `for_`

-like traversal without looking at the implementation – this makes making mistakes easy.

As we discussed in the previous section, it should be possible for a programmer to tell exactly how a Monad or Applicative will behave, without having to dig into implementations. Having a structure where `<*>`

and `ap`

behave slightly differently makes this hard.

When a Haskell programmer wants to make a clear distinction between two similar types, the first thing that comes to mind is probably `newtype`

s. This problem is no different.

Let’s introduce a newtype for error-collecting Applicative. Since the Functor instance is exactly the same, we might as well generate it using `GeneralizedNewtypeDeriving`

.

```
> newtype MonoidCheck e a = MonoidCheck {unMonoidCheck :: Check e a}
> deriving (Functor, Show)
```

Now, we provide our Applicative instance for `MonoidCheck`

:

```
> instance Monoid e => Applicative (MonoidCheck e) where
> pure x = MonoidCheck (Ok x)
>
> MonoidCheck l <*> MonoidCheck r = MonoidCheck $ case (l, r) of
> (Ok f , Ok x ) -> Ok (f x)
> (Ok _ , Failed e ) -> Failed e
> (Failed e , Ok _ ) -> Failed e
> (Failed e1, Failed e2) -> Failed (e1 <> e2)
```

Finally, we *avoid* writing a Monad instance for `MonoidCheck`

. This approach makes the code cleaner:

This ensures that when people use

`MonoidCheck`

, they are forced to use the Applicative combinators, and they cannot*accidentally*reduce the number of error messages.For other programmers reading the code, it is very clear whether we are dealing with short-circuiting behaviour or that we are collecting multiple error messages: it is explicit in the types.

Our fragment now becomes:

```
> findDefinedTypes3 :: Program -> Check [String] TypeScope
> findDefinedTypes3 _ = Ok [] -- Assume we can't define types for now.
```

```
> typeCheck3 :: TypeScope -> Expr -> MonoidCheck [String] Type
> typeCheck3 _ e = MonoidCheck $ Failed ["Could not typecheck: " ++ show e]
```

```
> compiler3 :: Check [String] ()
> compiler3 = do
> scope <- findDefinedTypes3 program1
> unMonoidCheck $ typeCheck3 scope expr1 *> typeCheck3 scope expr2
> return ()
```

We can see that while it is not more *concise*, it is definitely more *clear*: we can see exactly which functions will collect error messages. Furthermore, if we now try to write:

`typeCheck3 scope expr1 >> typeCheck3 scope expr2`

We will get a compiler warning telling us we should use `*>`

instead.

Explicitly, we now convert between `Check`

and `MonoidCheck`

by simply calling `MonoidCheck`

and `unMonoidCheck`

. We can do this inside other transformers if necessary, using e.g. `mapReaderT`

.

The `MonoidCheck`

discussed in this blogpost is available as Data.Either.Validation on hackage. The main difference is that instead of using a `newtype`

, the package authors provide a full-blown datatype.

```
> data Validation e a
> = Failure e
> | Success a
```

And two straightforward conversion functions:

```
> validationToEither :: Validation e a -> Either e a
> validationToEither (Failure e) = Left e
> validationToEither (Success x) = Right x
```

```
> eitherToValidation :: Either e a -> Validation e a
> eitherToValidation (Left e) = Failure e
> eitherToValidation (Right x) = Success x
```

This makes constructing values a bit easier:

`Failure ["Can't go mucking with a 'void*'"]`

Instead of:

`MonoidCheck $ Failed ["Can't go mucking with a 'void*'"]`

At this point, it shouldn’t surprise you that `Validation`

intentionally does not provide a Monad instance.

This, of course, is all my opinion – there doesn’t seem to be any *definite* consensus on whether or not `ap`

should be the same as `<*>`

, since differing behaviour occurs in prominent libraries. While the Monad and Applicative laws are relatively well known, there is no *canonical* law saying that `ap = <*>`

.

**Update**: there actually *is* a canonical law that `ap`

should be `<*>`

, and it was right under my nose in the Monad documentation since AMP. Before that, it was mentioned in the Applicative documentation. Thanks to quchen for pointing that out to me!

A key point here is that the AMP *actually* related the two typeclasses. Before that, arguing that the two classes were in a way “unrelated” was still a (dubious) option, but that is no longer the case.

Furthermore, considering this as a law might reveal opportunities for optimisation ^{2}.

Lastly, I am definitely a fan of implementing these differing behaviours using different types and then converting between them: the fact that types explicitly tell me about the behaviour of code is one of the reasons I like Haskell.

Thanks to Alex Sayers for proofreading and suggestions.

`ap`

is the Monadic sibling of`<*>`

(which explains why`<*>`

is commonly pronounced`ap`

). It can be implemented on top of`>>=`

/`return`

:↩`> ap :: Monad m => m (a -> b) -> m a -> m b > ap mf mx = do > f <- mf > x <- mx > return (f x)`

Take this with a grain of salt – Currently, GHC does not use any of the Monad laws to perform any optimisation. However, some Monad instances use them in

`RULES`

pragmas.↩

There has been a theme of “Practical Haskell” in the last few blogposts I published, and when I published the last one, on how to write an LRU Cache, someone asked me if I could elaborate on how I would test or benchmark such a module. For the sake of brevity, I will constrain myself to testing for now, although I think a lot of the ideas in the blogpost also apply to benchmarking.

This post is written in Literate Haskell. It depends on the LRU Cache we wrote last time, so you need both modules if you want to play around with the code. Both can be found in this repo.

Since I use a different format for blogpost filenames than GHC expects for module names, loading both modules is a bit tricky. The following works for me:

```
$ ghci posts/2015-02-24-lru-cache.lhs \
posts/2015-03-13-practical-testing-in-haskell.lhs
*Data.SimpleLruCache> :m +Data.SimpleLruCache.Tests
*Data.SimpleLruCache Data.SimpleLruCache.Tests>
```

Alternatively, you can of course rename the files.

There are roughly two kinds of test frameworks which are commonly used in the Haskell world:

Unit testing, for writing concrete test

*cases*. We will be using HUnit.Property testing, which allows you to test

*properties*rather than specific*cases*. We will be using QuickCheck. Property testing is something that might be unfamiliar to people just starting out in Haskell. However, because there already are great tutorials out there on there on QuickCheck, I will not explain it in detail. smallcheck also falls in this category.

Finally, it’s nice to have something to tie it all together. We will be using Tasty, which lets us run HUnit and QuickCheck tests in the same test suite. It also gives us plenty of convenient options, e.g. running only a part of the test suite. We could also choose to use test-framework or Hspec instead of Tasty.

Many Haskell projects start out by just having a `tests.hs`

file somewhere, but this obviously does not scale well to larger codebases.

The way I like to organize tests is based on how we organize code in general: through the module hierarchy. If I have the following modules in `src/`

:

```
AcmeCompany.AwesomeProduct.Database
AcmeCompany.AwesomeProduct.Importer
AcmeCompany.AwesomeProduct.Importer.Csv
```

I aim to have the following modules in `tests/`

:

```
AcmeCompany.AwesomeProduct.Database.Tests
AcmeCompany.AwesomeProduct.Importer.Tests
AcmeCompany.AwesomeProduct.Importer.Csv.Tests
```

If I want to add some higher-level tests which basically test the entire product, I can usually add these higher in the module tree. For example, if I wanted to test our entire awesome product, I would write the tests in `AcmeCompany.AwesomeProduct.Tests`

.

Every `.Tests`

module exports a `tests :: TestTree`

value. A `TestTree`

is a tasty concept – basically a structured group of tests. Let’s go to our motivating example: testing the LRU Cache I wrote in the previous blogpost.

Since I named the module `Data.SimpleLruCache`

, we use `Data.SimpleLruCache.Tests`

here.

```
> {-# OPTIONS_GHC -fno-warn-orphans #-}
> {-# LANGUAGE BangPatterns #-}
> {-# LANGUAGE GeneralizedNewtypeDeriving #-}
> module Data.SimpleLruCache.Tests
> ( tests
> ) where
```

```
> import Control.Applicative ((<$>), (<*>))
> import Control.DeepSeq (NFData)
> import Control.Monad (foldM_)
> import Data.Hashable (Hashable (..))
> import qualified Data.HashPSQ as HashPSQ
> import Data.IORef (newIORef, readIORef, writeIORef)
> import Data.List (foldl')
> import qualified Data.Set as S
> import Prelude hiding (lookup)
> import Data.SimpleLruCache
> import qualified Test.QuickCheck as QC
> import qualified Test.QuickCheck.Monadic as QC
> import Test.Tasty (TestTree, testGroup)
> import Test.Tasty.HUnit (testCase)
> import Test.Tasty.QuickCheck (testProperty)
> import Test.HUnit (Assertion, (@?=))
```

One of the hardest questions is, of course, which functions and modules should I test? If unlimited time and resources are available, the obvious answer is “everything”. Unfortunately, time and resources are often scarce.

My rule of thumb is based on my development style. I tend to use GHCi a lot during development, and play around with datastructures and functions until they seem to work. These “it seems to work” cases I execute in GHCi often make great candidates for simple HUnit tests, so I usually start with that.

Then I look at invariants of the code, and try to model these as QuickCheck properties. This sometimes requires writing tricky `Arbitrary`

instances; I will give an example of this later in this blogpost.

I probably don’t have to say that the more critical the code is, the more tests should be added.

After doing this, it is still likely that we will hit bugs if the code is non-trivial. These bugs form good candidates for testing as well:

- First, add a test case to reproduce the bug. Sometimes a test case will be a better fit, sometimes we should go with a property – it depends on the bug.
- Fix the bug so the test case passes.
- Leave in the test case for regression testing.

Using this strategy, you should be able to convince yourself (and others) that the code works.

Testing simple cases using HUnit is trivial, so we won’t spend that much time here. `@?=`

asserts that two values must be equal, so let’s use that to check that trimming the empty `Cache`

doesn’t do anything evil:

```
> testCache01 :: Assertion
> testCache01 =
> trim (empty 3 :: Cache String Int) @?= empty 3
```

If we need to some I/O for our test, we can do so without much trouble in HUnit. After all,

```
Test.HUnit> :i Assertion
type Assertion = IO () -- Defined in 'Test.HUnit.Lang'
```

so `Assertion`

is just `IO`

!

```
> testCache02 :: Assertion
> testCache02 = do
> h <- newHandle 10 :: IO (Handle String Int)
> v1 <- cached h "foo" (return 123)
> v1 @?= 123
> v2 <- cached h "foo" (fail "should be cached")
> v2 @?= 123
```

That was fairly easy.

As you can see, I usually give simple test cases numeric names. Sometimes there is a meaningful name for a test (for example, if it is a regression test for a bug), but usually I don’t mind using just numbers.

Let’s do some property based testing. There are a few properties we can come up with.

Calling `HashPSQ.size`

takes *O(n)* time, which is why are keeping our own counter, `cSize`

. We should check that it matches `HashPSQ.size`

, though:

```
> sizeMatches :: (Hashable k, Ord k) => Cache k v -> Bool
> sizeMatches c =
> cSize c == HashPSQ.size (cQueue c)
```

The `cTick`

field contains the priority of our next element that we will insert. The priorities currently in the queue should all be smaller than that.

```
> prioritiesSmallerThanNext :: (Hashable k, Ord k) => Cache k v -> Bool
> prioritiesSmallerThanNext c =
> all (< cTick c) priorities
> where
> priorities = [p | (_, p, _) <- HashPSQ.toList (cQueue c)]
```

Lastly, the size should always be smaller than or equal to the capacity:

```
> sizeSmallerThanCapacity :: (Hashable k, Ord k) => Cache k v -> Bool
> sizeSmallerThanCapacity c =
> cSize c <= cCapacity c
```

Of course, if you are somewhat familiar with QuickCheck, you will know that the previous properties require an `Arbitrary`

instance for `Cache`

.

One way to write such instances is what I’ll call the “direct” method. For us this would mean generating a list of `[(key, priority, value)]`

pairs and convert that to a `HashPSQ`

. Then we could compute the size of that and initialize the remaining fields.

However, writing an `Arbitrary`

instance this way can get hard if our datastructure becomes more complicated, especially if there are complicated invariants. Additionally, if we take any shortcuts in the implementation of `arbitrary`

, we might not test the edge cases well!

Another way to write the `Arbitrary`

instance is by modeling use of the API. In our case, there are only two things we can do with a pure `Cache`

: insert and lookup.

```
> data CacheAction k v
> = InsertAction k v
> | LookupAction k
> deriving (Show)
```

This has a trivial `Arbitrary`

instance:

```
> instance (QC.Arbitrary k, QC.Arbitrary v) =>
> QC.Arbitrary (CacheAction k v) where
> arbitrary = QC.oneof
> [ InsertAction <$> QC.arbitrary <*> QC.arbitrary
> , LookupAction <$> QC.arbitrary
> ]
```

And we can apply these actions to our pure `Cache`

to get a new `Cache`

:

```
> applyCacheAction
> :: (Hashable k, Ord k)
> => CacheAction k v -> Cache k v -> Cache k v
> applyCacheAction (InsertAction k v) c = insert k v c
> applyCacheAction (LookupAction k) c = case lookup k c of
> Nothing -> c
> Just (_, c') -> c'
```

You probably guessed where this was going by now: we can generate an arbitrary `Cache`

by generating a bunch of these actions and applying them one by one on top of the `empty`

cache.

```
> instance (QC.Arbitrary k, QC.Arbitrary v, Hashable k, NFData v, Ord k) =>
> QC.Arbitrary (Cache k v) where
> arbitrary = do
> capacity <- QC.choose (1, 50)
> actions <- QC.arbitrary
> let !cache = empty capacity
> return $! foldl' (\c a -> applyCacheAction a c) cache actions
```

Provided that we can model the complete user facing API using such an “action” datatype, I think this is a great way to write `Arbitrary`

instances. After all, our `Arbitrary`

instance should then be able to reach the same states as a user of our code.

An extension of this trick is using a separate datatype which holds the list of actions we used to generate the `Cache`

as well as the `Cache`

.

```
> data ArbitraryCache k v = ArbitraryCache [CacheAction k v] (Cache k v)
> deriving (Show)
```

When a test fails, we can then log the list of actions which got us into the invalid state – very useful for debugging. Furthermore, we can implement the `shrink`

method in order to try to reach a similar invalid state using less actions.

Now, note that our `Arbitrary`

instance is for `Cache k v`

, i.e., we haven’t chosen yet what we want to have as `k`

and `v`

for our tests. In this case `v`

is not so important, but the choice of `k`

is important.

We want to cover all corner cases, and this includes ensuring that we cover collisions. If we use `String`

or `Int`

as key type `k`

, collisions are very unlikely due to the high cardinality of both types. Since we are using a hash-based container underneath, hash collisions must also be covered.

We can solve both problems by introducing a `newtype`

which restricts the cardinality of `Int`

, and uses a “worse” (in the traditional sense) hashing method.

```
> newtype SmallInt = SmallInt Int
> deriving (Eq, Ord, Show)
```

```
> instance QC.Arbitrary SmallInt where
> arbitrary = SmallInt <$> QC.choose (1, 100)
```

```
> instance Hashable SmallInt where
> hashWithSalt salt (SmallInt x) = (salt + x) `mod` 10
```

Now let’s mix QuickCheck with monadic code. We will be testing the `Handle`

interface to our cache. This interface consists of a single method:

```
cached
:: (Hashable k, Ord k)
=> Handle k v -> k -> IO v -> IO v
```

We will write a property to ensure our cache retains and evicts the right key-value pairs. It takes two arguments: the capacity of the LRU Cache (we use a `SmallInt`

in order to get more evictions), and a list of key-value pairs we will insert using `cached`

(we use `SmallInt`

so we will cover collisions).

```
> historic
> :: SmallInt -- ^ Capacity
> -> [(SmallInt, String)] -- ^ Key-value pairs
> -> QC.Property -- ^ Property
> historic (SmallInt capacity) pairs = QC.monadicIO $ do
```

`QC.run`

is used to lift `IO`

code into the QuickCheck property monad `PropertyM`

– so it is a bit like a more concrete version of `liftIO`

. I prefer it here over `liftIO`

because it makes it a bit more clear what is going on.

`> h <- QC.run $ newHandle capacity`

We will fold (`foldM_`

) over the pairs we need to insert. The state we pass in this `foldM_`

is the history of pairs we previously inserted. By building this up again using `:`

, we ensure `history`

contains a recent-first list, which is very convenient.

Inside every step, we call `cached`

. By using an `IORef`

in the code where we would usually actually “load” the value `v`

, we can communicate whether or not the value was already in the cache. If it was already in the cache, the write will not be executed, so the `IORef`

will still be set to `False`

. We store that result in `wasInCache`

.

In order to verify this result, we reconstruct a set of the N most recent keys. We can easily do this using the list of recent-first key-value pairs we have in `history`

.

```
> foldM_ (step h) [] pairs
> where
> step h history (k, v) = do
> wasInCacheRef <- QC.run $ newIORef True
> _ <- QC.run $ cached h k $ do
> writeIORef wasInCacheRef False
> return v
> wasInCache <- QC.run $ readIORef wasInCacheRef
> let recentKeys = nMostRecentKeys capacity S.empty history
> QC.assert (S.member k recentKeys == wasInCache)
> return ((k, v) : history)
```

This is our auxiliary function to calculate the N most recent keys, given a recent-first key-value pair list.

```
> nMostRecentKeys :: Ord k => Int -> S.Set k -> [(k, v)] -> S.Set k
> nMostRecentKeys _ keys [] = keys
> nMostRecentKeys n keys ((k, _) : history)
> | S.size keys >= n = keys
> | otherwise =
> nMostRecentKeys n (S.insert k keys) history
```

This test did not cover checking that the *values* in the cache are correct, but only ensures it retains the correct key-value pairs. This is a conscious decision: I think the retaining/evicting part of the LRU Cache code was the most tricky, so we should prioritize testing that.

Lastly, we have our `tests :: TestTree`

. It is not much more than an index of tests in the module. We use `testCase`

to pass HUnit tests to the framework, and `testProperty`

for QuickCheck properties.

Note that I usually tend to put these at the top of the module, but here I put it at the bottom of the blogpost for easier reading.

```
> tests :: TestTree
> tests = testGroup "Data.SimpleLruCache"
> [ testCase "testCache01" testCache01
> , testCase "testCache02" testCache02
```

```
> , testProperty "size == HashPSQ.size"
> (sizeMatches :: Cache SmallInt String -> Bool)
> , testProperty "priorities < next priority"
> (prioritiesSmallerThanNext :: Cache SmallInt String -> Bool)
> , testProperty "size < capacity"
> (sizeSmallerThanCapacity :: Cache SmallInt String -> Bool)
```

```
> , testProperty "historic" historic
> ]
```

The last thing we need is a `main`

function for `cabal test`

to invoke. I usually put this in something like `tests/Main.hs`

. If you use the scheme which I described above, this file should look very neat:

```
module Main where
import Test.Tasty (defaultMain, testGroup)
import qualified AcmeCompany.AwesomeProduct.Database.Tests
import qualified AcmeCompany.AwesomeProduct.Importer.Csv.Tests
import qualified AcmeCompany.AwesomeProduct.Importer.Tests
import qualified Data.SimpleLruCache.Tests
main :: IO ()
main = defaultMain $ testGroup "Tests"
[ AcmeCompany.AwesomeProduct.Database.Tests.tests
, AcmeCompany.AwesomeProduct.Importer.Csv.Tests.tests
, AcmeCompany.AwesomeProduct.Importer.Tests.tests
, Data.SimpleLruCache.Tests.tests
]
```

If you are still hungry for more Haskell testing, I would recommend looking into Haskell program coverage for mission-critical modules.

Special thanks to Alex Sayers, who beat everyone’s expectations when he managed to stay sober for just long enough to proofread this blogpost.

]]>In-memory caches form an important optimisation for modern applications. This is one area where people often tend to write their own implementation (though usually based on an existing idea). The reason for this is mostly that having a one-size-fits all cache is really hard, and people often want to tune it for performance reasons according to their usage pattern, or use a specific interface that works really well for them.

However, this sometimes results in less-than-optimal design choices. I thought I would take some time and explain how an LRU cache can be written in a reasonably straightforward way (the code is fairly short), while still achieving great performance. Hence, it should not be too much trouble to tune this code to your needs.

The data structure usually underpinning an LRU cache is a Priority Search Queue, where the priority of an element is the time at which it was last accessed. A number of Priority Search Queue implementations are provided by the psqueues package, and in this blogpost we will be using its `HashPSQ`

data type.

*Disclaimer: I am one of the principal authors of the psqueues package.*

This blogpost is written in literate Haskell, so you should be able to plug it into GHCi and play around with it. The raw file can be found here.

First, we import some things, including the `Data.HashPSQ`

module from psqueues.

```
> {-# LANGUAGE BangPatterns #-}
> module Data.SimpleLruCache where
```

```
> import Control.Applicative ((<$>))
> import Data.Hashable (Hashable, hash)
> import qualified Data.HashPSQ as HashPSQ
> import Data.IORef (IORef, newIORef, atomicModifyIORef')
> import Data.Int (Int64)
> import Data.Maybe (isNothing)
> import qualified Data.Vector as V
> import Prelude hiding (lookup)
```

Let’s start with our datatype definition. Our `Cache`

type is parameterized by `k`

and `v`

, which represent the types of our keys and values respectively. The priorities of our elements will be the logical time at which they were last accessed, or the time at which they were inserted (for elements which have never been accessed). We will represent these logical times by values of type `Int64`

.

`> type Priority = Int64`

The `cTick`

field stores the “next” logical time – that is, the value of `cTick`

should be one greater than the maximum priority in `cQueue`

. At the very least, we need to maintain the invariant that all priorities in `cQueue`

are smaller than `cTick`

. A consequence of this is that `cTick`

should increase monotonically. This is violated in the case of an integer overflow, so we need to take special care of that case.

```
> data Cache k v = Cache
> { cCapacity :: !Int -- ^ The maximum number of elements in the queue
> , cSize :: !Int -- ^ The current number of elements in the queue
> , cTick :: !Priority -- ^ The next logical time
> , cQueue :: !(HashPSQ.HashPSQ k Priority v)
> } deriving (Eq, Show)
```

Creating an empty `Cache`

is easy; we just need to know the maximum capacity.

```
> empty :: Int -> Cache k v
> empty capacity
> | capacity < 1 = error "Cache.empty: capacity < 1"
> | otherwise = Cache
> { cCapacity = capacity
> , cSize = 0
> , cTick = 0
> , cQueue = HashPSQ.empty
> }
```

Next, we will write a utility function to ensure that the invariants of our datatype are met. We can then use that in our `lookup`

and `insert`

functions.

```
> trim :: (Hashable k, Ord k) => Cache k v -> Cache k v
> trim c
```

The first thing we want to check is if our logical time reaches the maximum value it can take. If this is the case, can either reset all the ticks in our queue, or we can clear it. We choose for the latter here, since that is simply easier to code, and we are talking about a scenario that should not happen very often.

`> | cTick c == maxBound = empty (cCapacity c)`

Then, we just need to check if our size is still within bounds. If it is not, we drop the oldest item – that is the item with the smallest priority. We will only ever need to drop one item at a time, because our cache is number-bounded and we will call `trim`

after every `insert`

.

```
> | cSize c > cCapacity c = c
> { cSize = cSize c - 1
> , cQueue = HashPSQ.deleteMin (cQueue c)
> }
> | otherwise = c
```

Insert is pretty straightforward to implement now. We use the `insertView`

function from `Data.HashPSQ`

which tells us whether or not an item was overwritten.

```
insertView
:: (Hashable k, Ord p, Ord k)
=> k -> p -> v -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v)
```

This is necessary, since we need to know whether or not we need to update `cSize`

.

```
> insert :: (Hashable k, Ord k) => k -> v -> Cache k v -> Cache k v
> insert key val c = trim $!
> let (mbOldVal, queue) = HashPSQ.insertView key (cTick c) val (cQueue c)
> in c
> { cSize = if isNothing mbOldVal then cSize c + 1 else cSize c
> , cTick = cTick c + 1
> , cQueue = queue
> }
```

Lookup is not that hard either, but we need to remember that in addition to looking up the item, we also want to bump the priority. We can do this using the `alter`

function from psqueues: that allows us to modify a value (bump its priority) and return something (the value, if found) at the same time.

```
alter
:: (Hashable k, Ord k, Ord p)
=> (Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> HashPSQ.HashPSQ k p v -> (b, HashPSQ.HashPSQ k p v)
```

The `b`

in the signature above becomes our lookup result.

```
> lookup
> :: (Hashable k, Ord k) => k -> Cache k v -> Maybe (v, Cache k v)
> lookup k c = case HashPSQ.alter lookupAndBump k (cQueue c) of
> (Nothing, _) -> Nothing
> (Just x, q) ->
> let !c' = trim $ c {cTick = cTick c + 1, cQueue = q}
> in Just (x, c')
> where
> lookupAndBump Nothing = (Nothing, Nothing)
> lookupAndBump (Just (_, x)) = (Just x, Just ((cTick c), x))
```

That basically gives a clean and simple implementation of a pure LRU Cache. If you are only writing pure code, you should be good to go! However, most applications deal with caches in IO, so we will have to adjust it for that.

Using an `IORef`

, we can update our `Cache`

to be easily usable in the IO Monad.

`> newtype Handle k v = Handle (IORef (Cache k v))`

Creating one is easy:

```
> newHandle :: Int -> IO (Handle k v)
> newHandle capacity = Handle <$> newIORef (empty capacity)
```

Our simple interface only needs to export one function. `cached`

takes the key of the value we are looking for, and an `IO`

action which produces the value. However, we will only actually execute this `IO`

action if it is not present in the cache.

```
> cached
> :: (Hashable k, Ord k)
> => Handle k v -> k -> IO v -> IO v
> cached (Handle ref) k io = do
```

First, we check the cache using our `lookup`

function from above. This uses `atomicModifyIORef'`

, since our `lookup`

might bump the priority of an item, and in that case we modify the cache.

```
> lookupRes <- atomicModifyIORef' ref $ \c -> case lookup k c of
> Nothing -> (c, Nothing)
> Just (v, c') -> (c', Just v)
```

If it is found, we can just return it.

```
> case lookupRes of
> Just v -> return v
```

Otherwise, we execute the `IO`

action and call `atomicModifyIORef'`

again to insert it into the cache.

```
> Nothing -> do
> v <- io
> atomicModifyIORef' ref $ \c -> (insert k v c, ())
> return v
```

This scheme already gives us fairly good performance. However, that can degrade a little when lots of threads are calling `atomicModifyIORef'`

on the same `IORef`

.

`atomicModifyIORef'`

is implemented using a compare-and-swap, so conceptually it works a bit like this:

```
atomicModifyIORef' :: IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' ref f = do
x <- readIORef ref
let (!x', !y) = f x
-- Atomically write x' if value is still x
swapped <- compareAndSwap ref x x'
if swapped
then return y
else atomicModifyIORef' ref f -- Retry
```

We can see that this can lead to contention: if we have a lot of concurrent `atomicModifyIORef'`

s, we can get into a retry loop. It cannot cause a deadlock (i.e., it should still eventually finish), but it will still bring our performance to a grinding halt. This is a common problem with `IORef`

s which I have also personally encountered in real-world scenarios.

A good solution around this problem, since we already have a `Hashable`

instance for our key anyway, is striping the keyspace. We can even reuse our `Handle`

in quite an elegant way. Instead of just using one `Handle`

, we create a `Vector`

of `Handle`

s instead:

`> newtype StripedHandle k v = StripedHandle (V.Vector (Handle k v))`

The user can configure the number of handles that are created:

```
> newStripedHandle :: Int -> Int -> IO (StripedHandle k v)
> newStripedHandle numStripes capacityPerStripe =
> StripedHandle <$> V.replicateM numStripes (newHandle capacityPerStripe)
```

Our hash function then determines which `Handle`

we should use:

```
> stripedCached
> :: (Hashable k, Ord k)
> => StripedHandle k v -> k -> IO v -> IO v
> stripedCached (StripedHandle v) k =
> cached (v V.! idx) k
> where
> idx = hash k `mod` V.length v
```

Because our access pattern is now distributed among the different `Handle`

s, we should be able to avoid the contention problem.

We have implemented a very useful data structure for many applications, with two variations and decent performance. Thanks to the psqueues package, the implementations are very straightforward, small in code size, and it should be possible to tune the caches to your needs.

Many variations are possible: you can use real timestamps (`UTCTime`

) as priorities in the queue and have items expire after a given amount of time. Or, if modifications of the values `v`

are allowed, you can add a function which writes the updates to the cache as well as to the underlying data source.

For embedding the pure cache into IO, there many alternatives to using `IORef`

s: for example, we could have used `MVar`

s or `TVar`

s. There are other strategies for reducing contention other than striping, too.

You could even write a cache which is bounded by its total size on the heap, rather than by the number of elements in the queue. If you want a single bounded cache for use across your entire application, you could allow it to store heterogeneously-typed values, and provide multiple strongly-typed interfaces to the same cache. However, implementing these things is a story for another time.

Thanks to the dashing Alex Sayers for proofreading and suggesting many corrections and improvements.

]]>For a long time, I have wanted to write a series of blogposts about Design Patterns in Haskell. This never really worked out. It is hard to write about Design Patterns.

First off, I have been writing Haskell for a long time, so mostly things feel natural and I do not really think about code in terms of Design Patterns.

Additionaly, I think there is a very, very thin line between what we call “Design Patterns” and what we call “Common Sense”. Too much on one side of the line, and you sound like a complete idiot. Too much on the other side of the line, and you sound like a pretentious fool who needs five UML diagrams in order to write a 100-line program.

However, in the last year, I have both been teaching more Haskell, and I have been reading even more code written by other people. The former made me think harder about why I do things, and the latter made me notice patterns I hadn’t thought of before, in particular if they were formulated in another way.

This has given me a better insight into these patterns, so I hope to write a couple of blogposts like this over the next couple of months. We will see how it goes – I am not exactly a prolific blogger.

The first blogpost deals with what I call `.Extended`

Modules. While the general idea has probably been around for a while, the credit for this specific scheme goes to Bas van Dijk, Simon Meier, and Thomas Schilling.

This problem mainly resolves around *organisation* of code.

Haskell allows for building complex applications out of small functions that compose well. Naturally, if you are building a large application, you end up with a *lot* of these small functions.

Imagine we are building some web application, and we have a small function that takes a value and then sends it to the browser as JSON:

```
json :: (MonadSnap m, Aeson.ToJSON a) => a -> m ()
json x = do
modifyResponse $ setContentType "application/json"
writeLBS $ Aeson.encode x
```

The question is: where do we put this function? In small projects, these seem to inevitably end up inside the well-known `Utils`

module. In larger, or more well-organised projects, it might end up in `Foo.Web`

or `Foo.Web.Utils`

.

However, if we think outside of the box, and disregard dependency problems and libraries including every possible utility function one can write, it is clearer where this function should go: in `Snap.Core`

.

Putting it in `Snap.Core`

is obviously not a solution – imagine the trouble library maintainers would have to deal with in order to include all these utility functions.

The scheme we use to solve this is simple yet powerful: in our own application’s non-exposed modules list, we add `Snap.Core.Extended`

.

`src/Snap/Core/Extended.hs`

:

```
{-# LANGUAGE OverloadedStrings #-}
module Snap.Core.Extended
( module Snap.Core
, json
) where
import qualified Data.Aeson as Aeson
import Snap.Core
json :: (MonadSnap m, Aeson.ToJSON a) => a -> m ()
json x = do
modifyResponse $ setContentType "application/json"
writeLBS $ Aeson.encode x
```

The important thing to notice here is the re-export of `module Snap.Core`

. This means that, everywhere in our application, we can use `import Snap.Core.Extended`

as a drop-in replacement for `import Snap.Core`

.

This also makes sharing code in a team easier. For example, say that you are looking for a `catMaybes`

for `Data.Vector`

.

Before, I would have considered either defining this in a `where`

clause, or locally as a non-exported function. This works for single-person projects, but not when different people are working on different modules: you end up with five implementations of this method, scattered throughout the codebase.

With this scheme, however, it’s clear where to look for such a method: in `Data.Vector.Extended`

. If it’s not there, you add it.

Aside from utility functions, this scheme also works great for orphan instances. For example, if we want to serialize a `HashMap k v`

by converting it to `[(k, v)]`

, we can add a `Data.HashMap.Strict.Extended`

module.

`src/Data/HashMap/Strict/Extended.hs`

:

```
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.HashMap.Strict.Extended
( module Data.HashMap.Strict
) where
import Data.Binary (Binary (..))
import Data.Hashable (Hashable)
import Data.HashMap.Strict
instance (Binary k, Binary v, Eq k, Hashable k) => Binary (HashMap k v) where
put = put . toList
get = fmap fromList get
```

A special case of these `.Extended`

modules is `Prelude.Extended`

. Since you will typically import `Prelude.Extended`

into almost all modules in your application, it is a great way to add a bunch of (very) common imports from `base`

, so import noise is reduced.

This is, of course, quite subjective. Some might want to add a few specific functions to `Prelude`

(as illustrated below), and others might prefer to add all of `Control.Applicative`

, `Data.List`

, `Data.Maybe`

, and so on.

`src/Prelude/Extended.hs`

:

```
module Prelude.Extended
( module Prelude
, foldl'
, fromMaybe
) where
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Prelude
```

The basic scheme breaks once our application consists of several cabal packages.

If we have a package `acmecorp-web`

, which depends on `acmecorp-core`

, we would have to expose `Data.HashMap.Strict.Extended`

from `acmecorp-core`

, which feels weird.

A simple solution is to create an `unordered-containers-extended`

package (which is **not** uploaded to the public Hackage for obvious reasons). Then, you can export `Data.HashMap.Strict.Extended`

from there.

This solution creates quite a lot of overhead. Having many modules is fine, since they are easy to manage – they are just files after all. Managing many packages, however, is harder: every package introduces a significant amount of overhead: for example, repos need to be maintained, and dependencies need to be managed explicitly in the cabal file.

An alternative solution is to simply put all of these modules together in a `hackage-extended`

package. This solves the maintenance overhead and still gives you a very clean module hierarchy.

After using this scheme for over year in a large, constantly evolving Haskell application, it is clear to me that this is a great way to organise and share code in a team.

A side-effect of this scheme is that it becomes very convenient to consider some utility functions from these `.Extended`

modules for inclusion in their respective libraries, since they all live in the same place. If they do get added, just remove the originals from hackage-extended, and the rest of your code doesn’t even break!

Thanks to Alex Sayers for proofreading!

]]>A Comonad is a structure from category theory dual to Monad.

Comonads are well-suited for image processing

– Pretty much everyone on the internet

Whenever Comonads come up, people usually mention the canonical example of evaluating cellular automata. Because many image processing algorithms can be modelled as a cellular automaton, this is also a frequently mentioned example.

However, when I was trying to explain Comonads to a friend recently, I couldn’t find any standalone example of how exactly this applies to image processing, so I decided to illustrate this myself.

I will not attempt to explain Comonads, for that I refer to Gabriel Gonzalez’ excellent blogpost. This blogpost is written in literate Haskell so you should be able to just load it up in GHCi and play around with it (you can find the raw `.lhs`

file here).

```
> {-# LANGUAGE BangPatterns #-}
> import qualified Codec.Picture as Juicy
> import Control.Applicative ((<$>))
> import Data.List (sort)
> import Data.Maybe (fromMaybe, maybeToList)
> import qualified Data.Vector as V
> import qualified Data.Vector.Generic as VG
> import Data.Word (Word8)
```

We need a simple type for images. Let’s use the great JuicyPixels library to read and write images. Unfortunately, we cannot use the image type defined in JuicyPixels, since JuicyPixels stores pixels in a Storable-based Vector.

We want to be able to store any kind of pixel value, not just `Storable`

values, so we declare our own `BoxedImage`

. We will simply store pixels in row-major order in a boxed `Vector`

.

```
> data BoxedImage a = BoxedImage
> { biWidth :: !Int
> , biHeight :: !Int
> , biData :: !(V.Vector a)
> }
```

Because our `BoxedImage`

allows any kind of pixel value, we get a straightforward `Functor`

instance:

```
> instance Functor BoxedImage where
> fmap f (BoxedImage w h d) = BoxedImage w h (fmap f d)
```

Now, we want to be able to convert from a JuicyPixels image to our own `BoxedImage`

and back again. In this blogpost, we will only deal with grayscale images (`BoxedImage Word8`

), since this makes the image processing algorithms mentioned here a lot easier to understand.

`> type Pixel = Word8 -- Grayscale`

```
> boxImage :: Juicy.Image Juicy.Pixel8 -> BoxedImage Pixel
> boxImage image = BoxedImage
> { biWidth = Juicy.imageWidth image
> , biHeight = Juicy.imageHeight image
> , biData = VG.convert (Juicy.imageData image)
> }
```

```
> unboxImage :: BoxedImage Pixel -> Juicy.Image Juicy.Pixel8
> unboxImage boxedImage = Juicy.Image
> { Juicy.imageWidth = biWidth boxedImage
> , Juicy.imageHeight = biHeight boxedImage
> , Juicy.imageData = VG.convert (biData boxedImage)
> }
```

With the help of `boxImage`

and `unboxImage`

, we can now call out to the JuicyPixels library:

```
> readImage :: FilePath -> IO (BoxedImage Pixel)
> readImage filePath = do
> errOrImage <- Juicy.readImage filePath
> case errOrImage of
> Right (Juicy.ImageY8 img) -> return (boxImage img)
> Right _ ->
> error "readImage: unsupported format"
> Left err ->
> error $ "readImage: could not load image: " ++ err
```

```
> writePng :: FilePath -> BoxedImage Pixel -> IO ()
> writePng filePath = Juicy.writePng filePath . unboxImage
```

While we can already write simple image processing algorithms (e.g. tone mapping) using just the `Functor`

interface, the kind of algorithms we are interested in today need take a *neighbourhood* of input pixels in order to produce a single output pixel.

For this purpose, let us create an additional type that focuses on a specific location in the image. We typically want to use a smart constructor for this, so that we don’t allow focusing on an `(x, y)`

-pair outside of the `piBoxedImage`

.

```
> data FocusedImage a = FocusedImage
> { piBoxedImage :: !(BoxedImage a)
> , piX :: !Int
> , piY :: !Int
> }
```

Conversion to and from a `BoxedImage`

is easy:

```
> focus :: BoxedImage a -> FocusedImage a
> focus bi
> | biWidth bi > 0 && biHeight bi > 0 = FocusedImage bi 0 0
> | otherwise =
> error "Cannot focus on empty images"
```

```
> unfocus :: FocusedImage a -> BoxedImage a
> unfocus (FocusedImage bi _ _) = bi
```

And the functor instance is straightforward, too:

```
> instance Functor FocusedImage where
> fmap f (FocusedImage bi x y) = FocusedImage (fmap f bi) x y
```

Now, we can implement the fabled Comonad class:

```
> class Functor w => Comonad w where
> extract :: w a -> a
> extend :: (w a -> b) -> w a -> w b
```

The implementation of `extract`

is straightforward. `extend`

is a little trickier. If we look at it’s concrete type:

`extend :: (FocusedImage a -> b) -> FocusedImage a -> FocusedImage b`

We want to convert all pixels in the image, and the conversion function is supplied as `f :: FocusedImage a -> b`

. In order to apply this to all pixels in the image, we must thus create a `FocusedImage`

for every position in the image. Then, we can simply pass this to `f`

which gives us the result at that position.

```
> instance Comonad FocusedImage where
> extract (FocusedImage bi x y) =
> biData bi V.! (y * biWidth bi + x)
>
> extend f (FocusedImage bi@(BoxedImage w h _) x y) = FocusedImage
> (BoxedImage w h $ V.generate (w * h) $ \i ->
> let (y', x') = i `divMod` w
> in f (FocusedImage bi x' y'))
> x y
```

Proving that this instance adheres to the Comonad laws is a bit tedious but not that hard if you make some assumptions such as:

`V.generate (V.length v) (\i -> v V.! i) = v`

We’re almost done with our mini-framework. One thing that remains is that we want to be able to look around in a pixel’s neighbourhood easily. In order to do this, we create this function which shifts the focus by a given pair of coordinates:

```
> neighbour :: Int -> Int -> FocusedImage a -> Maybe (FocusedImage a)
> neighbour dx dy (FocusedImage bi x y)
> | outOfBounds = Nothing
> | otherwise = Just (FocusedImage bi x' y')
> where
> x' = x + dx
> y' = y + dy
> outOfBounds =
> x' < 0 || x' >= biWidth bi ||
> y' < 0 || y' >= biHeight bi
```

If you have ever taken a photo when it is fairly dark, you will notice that there is typically a lot of noise. We’ll start from this photo which I took a couple of weeks ago, and try to reduce the noise in the image using our Comonad-based mini-framework.

A really easy noise reduction algorithm is one that looks at a local neighbourhood of a pixel, and replaces that pixel by the median of all the pixels in the neighbourhood. This can be easily implemented using `neighbour`

and `extract`

:

```
> reduceNoise1 :: FocusedImage Pixel -> Pixel
> reduceNoise1 pixel = median
> [ extract p
> | x <- [-2, -1 .. 2], y <- [-2, -1 .. 2]
> , p <- maybeToList (neighbour x y pixel)
> ]
```

Note how our Comonadic function takes the form of `w a -> b`

. With a little intuition, we can see how this is the dual of a monadic function, which would be of type `a -> m b`

.

We used an auxiliary function which simply gives us the median of a list:

```
> median :: Integral a => [a] -> a
> median xs
> | odd len = sort xs !! (len `div` 2)
> | otherwise = case drop (len `div` 2 - 1) (sort xs) of
> (x : y : _) -> x `div` 2 + y `div` 2
> _ -> error "median: empty list"
> where
> !len = length xs
```

So `reduceNoise1`

is a function which takes a pixel in the context of its neighbours, and returns a new pixel. We can use `extend`

to apply this comonadic action to an entire image:

`extend reduceNoise1 :: FocusedImage Pixel -> FocusedImage Pixel`

Running this algorithm on our original picture already gives an interesting result, and the noise has definitely been reduced. However, you will notice that it has this watercolour-like look, which is not what we want.

A more complicated noise-reduction filter uses a blur effect first. We can implement a blur by replacing each pixel by a weighted sum of its neighbouring pixels. At the edges, we just keep the pixels as-is.

This function implements the simple blurring kernel:

```
> blur :: FocusedImage Pixel -> Pixel
> blur pixel = fromMaybe (extract pixel) $ do
> let self = fromIntegral (extract pixel) :: Int
> topLeft <- extractNeighbour (-1) (-1)
> top <- extractNeighbour 0 (-1)
> topRight <- extractNeighbour 1 (-1)
> right <- extractNeighbour 1 0
> bottomRight <- extractNeighbour 1 1
> bottom <- extractNeighbour 0 1
> bottomLeft <- extractNeighbour (-1) 1
> left <- extractNeighbour (-1) 0
> return $ fromIntegral $ (`div` 16) $
> self * 4 +
> top * 2 + right * 2 + bottom * 2 + left * 2 +
> topLeft + topRight + bottomRight + bottomLeft
> where
> extractNeighbour :: Int -> Int -> Maybe Int
> extractNeighbour x y = fromIntegral . extract <$> neighbour x y pixel
```

The result is the following image:

This image contains less noise, but as we expected, it is blurry. This is not unfixable though: if we subtract the blurred picture from the original picture, we get the edges:

If we apply a high-pass filter here, i.e., we drop all edges below a certain threshold, such that we only retain the “most significant” edges, we get something like:

While there is still some noise, we can see that it’s clearly been reduced. If we now add this to the blurred image, we get our noise-reduced image number #2. The noise is not reduced as much as in the first image, but we managed to keep more texture in the image (and not make it look like a watercolour).

Our second noise reduction algorithm is thus:

```
> reduceNoise2 :: FocusedImage Pixel -> Pixel
> reduceNoise2 pixel =
> let !original = extract pixel
> !blurred = blur pixel
> !edge = fromIntegral original - fromIntegral blurred :: Int
> !threshold = if edge < 7 && edge > (-7) then 0 else edge
> in fromIntegral $ fromIntegral blurred + threshold
```

We can already see how the Comonad pattern lets us combine `extract`

and `blur`

, and simple arithmetic to achieve powerful results.

That we are able to compose these functions easily is even more apparent if we try to build a hybrid filter, which uses a weighted sum of the original, `reduceNoise1`

, and `reduceNoise2`

.

```
> reduceNoise3 :: FocusedImage Pixel -> Pixel
> reduceNoise3 pixel =
> let !original = extract pixel
> !reduced1 = reduceNoise1 pixel
> !reduced2 = reduceNoise2 pixel
> in (original `div` 4) + (reduced1 `div` 4) + (reduced2 `div` 2)
```

The noise here has been reduced significantly, while not making the image look like a watercolour. Success!

Here is our main function which ties everything up:

```
> main :: IO ()
> main = do
> image <- readImage filePath
> writePng "images/2014-11-27-stairs-reduce-noise-01.png" $
> unfocus $ extend reduceNoise1 $ focus image
> writePng "images/2014-11-27-stairs-reduce-noise-02.png" $
> unfocus $ extend reduceNoise2 $ focus image
> writePng "images/2014-11-27-stairs-reduce-noise-03.png" $
> unfocus $ extend reduceNoise3 $ focus image
> where
> filePath = "images/2014-11-27-stairs-original.png"
```

And here is a 300% crop which should show the difference between the original (left) and the result of `reduceNoise3`

(right) better:

I hope this example has given some intuition as to how Comonads can be used in real-world scenarios. For me, what made the click was realising how `w a -> b`

for Comonad relates to `a -> m b`

for Monad, and how these types of functions naturally compose well.

Additionally, I hope this blogpost provided some insight the image processing algorithms as well, which I also think is an interesting field.

Thanks to Alex Sayers for proofreading!

]]>In this blogpost I present a proof-of-concept operator `$.$`

, which allows you to replace:

`foo x0 x1 x2 ... xN = bar $ qux x0 x1 x2 ... xN`

by:

`foo = bar $.$ qux`

This is a literate Haskell file, which means you should be able to just drop it into GHCi and play around with it. You can find the raw `.lhs`

file here. Do note that this requires GHC 7.8 (it was tested on GHC 7.8.2).

```
> {-# LANGUAGE FlexibleContexts #-}
> {-# LANGUAGE FlexibleInstances #-}
> {-# LANGUAGE OverlappingInstances #-}
> {-# LANGUAGE TypeFamilies #-}
> {-# LANGUAGE TypeOperators #-}
```

`> import Data.Char (toLower)`

If you have been writing Haskell code for a while, you have undoubtedly used the `$`

operator to “wrap” some expression with another function, mapping over the result type. For example, we can “wrap” the expression `toLower 'A'`

with `print`

to output the result.

`print $ toLower 'A'`

It is not unlikely either to have functions that just wrap other functions, e.g.:

```
> printLower :: Char -> IO ()
> printLower x = print $ toLower x
```

If the function that is being wrapped (`toLower`

in the previous example) has only one argument, the `.`

operator allows writing a very concise definition of functions which just wrap those single-argument functions.

```
> printLower' :: Char -> IO ()
> printLower' = print . toLower
```

However, this gets tedious when the number arguments increases. Say that we have the following function which takes three arguments (don’t worry about the horrible implementation, but rather focus on the type):

```
> -- | Formats a double using a simple spec. Doesn't do proper rounding.
> formatDouble
> :: Bool -- ^ Drop trailing '0'?
> -> Int -- ^ #digits after decimal point
> -> Double -- ^ Argument
> -> String -- ^ Result
> formatDouble dropTrailingZero numDigits double =
> let (pre, post) = case break (== '.') (show double) of
> (x, '.' : y) -> (x, y)
> (x, y) -> (x, y)
> post' = take numDigits (post ++ repeat '0')
> pre' = case pre of
> '0' : x -> if dropTrailingZero then x else pre
> _ -> pre
> in pre' ++ "." ++ post'
```

We can wrap `formatDouble`

using print by successively using the `.`

operator, but the result does not look pretty, nor very readable:

```
> printDouble :: Bool -> Int -> Double -> IO ()
> printDouble = (.) ((.) ((.) print)) formatDouble
```

`$.$`

operatorThis makes one wonder if we can’t define an additional operator `$.$`

(pronounced *holla-holla-get-dolla*) which can be used like this:

```
> printDouble' :: Bool -> Int -> Double -> IO ()
> printDouble' = print $.$ formatDouble
```

Additionally, it should be *generic*, as in, it should work for an arbitrary number of arguments, so that we can also have:

```
> printMax' :: Int -> Int -> IO ()
> printMax' = print $.$ max
```

```
> printLower'' :: Char -> IO ()
> printLower'' = print $.$ toLower
```

From this, it becomes clear that the type of `$.$`

should be *something like*:

```
($.$)
:: (a -> b)
-> (x0 -> x1 -> ... -> xn -> a)
-> (x0 -> x1 -> ... -> xn -> b)
```

The first question is obviously, *can* we write such an operator? And if we can, how generic is it?

When my colleague Alex asked me this question, I spent some time figuring it out. I previously thought it was not possible to write such an operator in a reasonably nice way, but after some experiments with the closed type families in GHC 7.8 I managed to get something working. However, the solution is far from trivial (and I now suspect more elegant solutions might exist).

Thanks to my colleague Alex for proofreading!

]]>GHC comes with some amazing tools to do profiling of Haskell programs. In `.prof`

files, you can see exactly in which function most time is spent and where most allocation is done.

However, at Erudify, we have a huge amount of Haskell code – and at this point `.prof`

files can become very unwieldy, and the text representation is harder to grok.

This is why I coded profiteur, a simple HTML-based visualiser for GHC `.prof`

files.

Installation is easy:

`$ cabal install profiteur`

Let us grab a sample program from the HaskellWiki. The code of this sample program can be found in the appendix. I saved this file as `binary-trees.hs`

.

First, we compile it with profiling enabled:

```
$ ghc --make -auto-all -prof -rtsopts binary-trees.hs
[1 of 1] Compiling Main ( binary-trees.hs, binary-trees.o )
Linking binary-trees ...
```

We run it in profiling mode:

```
$ ./binary-trees 10 +RTS -p -RTS
stretch tree of depth 11 check: -1
2048 trees of depth 4 check: -2048
512 trees of depth 6 check: -512
128 trees of depth 8 check: -128
32 trees of depth 10 check: -32
long lived tree of depth 10 check: -1
```

This generates the file `binary-trees.prof`

. We can pass that to `profiteur`

:

```
$ profiteur binary-trees.prof
Wrote binary-trees.prof.html
```

Open the resulting file in your favorite (modern) browser and you are good to go! Here is the resulting HTML file so you can have a look without installing `profiteur`

.

As always, patches and pull requests are welcome on GitHub.

Code used:

```
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
--
-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- Contributed by Don Stewart
--
import System.Environment
import Data.Bits
import Text.Printf
data Tree = Nil | Node !Int Tree Tree
minN = 4
io s !n !t = printf "%s of depth %d\t check: %d\n" s n t
main = do
n <- getArgs >>= readIO . head
let maxN = max (minN + 2) n
stretchN = maxN + 1
-- stretch memory tree
let c = check (make 0 stretchN)
io "stretch tree" stretchN c
-- allocate a long lived tree
let long = make 0 maxN
-- allocate, walk, and deallocate many bottom-up binary trees
let vs = depth minN maxN
mapM_ (\((m,d,i)) -> io (show m ++ "\t trees") d i) vs
-- confirm the the long-lived binary tree still exists
io "long lived tree" maxN (check long)
-- generate many trees
depth :: Int -> Int -> [(Int,Int,Int)]
depth !d !m
| d <= m = (2*n,d,sumT d n 0) : depth (d+2) m
| otherwise = []
where !n = 1 `shiftL` (m - d + minN)
-- allocate and check lots of trees
sumT :: Int -> Int -> Int -> Int
sumT !d 0 t = t
sumT d i t = sumT d (i-1) (t + a + b)
where a = check (make i d)
b = check (make (-i) d)
-- traverse the tree, counting up the nodes
check :: Tree -> Int
check Nil = 0
check (Node i l r) = i + check l - check r
-- build a tree
make :: Int -> Int -> Tree
make i 0 = Node i Nil Nil
make i d = Node i (make (i2-1) d2) (make i2 d2)
where i2 = 2*i; d2 = d-1
```

A week or so ago, I wrote Lorem Markdownum: a small webapp to generate random text (like the many lorem ipsum generators out there), but in markdown format.

This blogpost explains a mildly interesting algorithm I used to pick a random element from a frequency list. It is written in Literate Haskell so you should be able to drop it into a file and run it – the raw version can be found here.

```
> import Data.List (sortBy)
> import Data.Ord (comparing)
> import qualified Data.Map.Strict as M
> import System.Random (randomRIO)
```

Lorem ipsum generators usually create random but realistic-looking text by using sample data, on which a model is trained. A very simple example of that is just to pick words according to their frequencies. Let us take some sample data from a song that fundamentally changed the music industry in the early 2000s:

Badger badger badger

Mushroom mushroom

Badger badger badger

Panic, a snake

Badger badger badger

Oh, it’s a snake!

This gives us the following frequency list:

```
> badgers :: [(String, Int)]
> badgers =
> [ ("a", 2)
> , ("badger", 9)
> , ("it's", 1)
> , ("mushroom", 2)
> , ("oh", 1)
> , ("panic", 1)
> , ("snake", 2)
> ]
```

The sum of all the frequencies in this list is 18. This means that we will e.g. pick “badger” with a chance of 9/18. We can naively implement this by expanding the list so it contains the items in the given frequencies and then picking one randomly.

```
> decodeRle :: [(a, Int)] -> [a]
> decodeRle [] = []
> decodeRle ((x, f) : xs) = replicate f x ++ decodeRle xs
```

```
> sample1 :: [(a, Int)] -> IO a
> sample1 freqs = do
> let expanded = decodeRle freqs
> idx <- randomRIO (0, length expanded - 1)
> return $ expanded !! idx
```

This is obviously extremely inefficient, and it is not that hard to come up with a better definition: we do not expand the list, and instead use a specialised indexing function for frequency lists.

```
> indexFreqs :: Int -> [(a, Int)] -> a
> indexFreqs _ [] = error "please reboot computer"
> indexFreqs idx ((x, f) : xs)
> | idx < f = x
> | otherwise = indexFreqs (idx - f) xs
```

```
> sample2 :: [(a, Int)] -> IO a
> sample2 freqs = do
> idx <- randomRIO (0, sum (map snd freqs) - 1)
> return $ indexFreqs idx freqs
```

However, `sample2`

is still relatively slow when we our sample data consists of a large amount of text (imagine what happens if we have a few thousand different words). Can we come up with a better but still elegant solution?

Note that lorem ipsum generators generally employ more complicated strategies than just picking a word according to the frequencies in the sample data. Usually, algorithms based on Markov Chains are used. But even when this is the case, picking a word with some given frequencies is still a subproblem that needs to be solved.

It is easy to see why `sample2`

is relatively slow: indexing in a linked list is expensive. Purely functional programming languages usually solve this by using trees instead of lists where fast indexing is required. We can use a similar approach here.

A leaf in the tree simply holds an item and its frequency. A branch also holds a frequency – namely, the sum of the frequencies of its children. By storing this computed value, we will be able to write a fast indexing this method.

```
> data FreqTree a
> = Leaf !Int !a
> | Branch !Int (FreqTree a) (FreqTree a)
> deriving (Show)
```

A quick utility function to get the sum of the frequencies in such a tree:

```
> sumFreqs :: FreqTree a -> Int
> sumFreqs (Leaf f _) = f
> sumFreqs (Branch f _ _) = f
```

Let us look at the tree for `badgers`

(we will discuss how this tree is computed later):

Once we have this structure, it is not that hard to write a faster indexing function, which is basically a search in a binary tree:

```
> indexFreqTree :: Int -> FreqTree a -> a
> indexFreqTree idx tree = case tree of
> (Leaf _ x) -> x
> (Branch _ l r)
> | idx < sumFreqs l -> indexFreqTree idx l
> | otherwise -> indexFreqTree (idx - sumFreqs l) r
```

```
> sample3 :: FreqTree a -> IO a
> sample3 tree = do
> idx <- randomRIO (0, sumFreqs tree - 1)
> return $ indexFreqTree idx tree
```

There we go! We intuitively see this method is faster since we only have to walk through a few nodes – namely, those on the path from the root node to the specific leaf node.

But how fast is this, exactly? This depends on how we build the tree.

Given a list with frequencies, we can build a nicely balanced tree (i.e., in the sense in which binary tries are balanced). This minimizes the longest path from the root to any node.

We first have a simple utility function to clean up such a list of frequencies:

```
> uniqueFrequencies :: Ord a => [(a, Int)] -> [(a, Int)]
> uniqueFrequencies =
> M.toList . M.fromListWith (+) . filter ((> 0) . snd)
```

And then we have the function that actually builds the tree. For a singleton list, we just return a leaf. Otherwise, we simply split the list in half, build trees out of those halves, and join them under a new parent node. Computing the total frequency of the parent node (`freq`

) is done a bit inefficiently, but that is not the focus at this point.

```
> balancedTree :: Ord a => [(a, Int)] -> FreqTree a
> balancedTree = go . uniqueFrequencies
> where
> go [] = error "balancedTree: Empty list"
> go [(x, f)] = Leaf f x
> go xs =
> let half = length xs `div` 2
> (ys, zs) = splitAt half xs
> freq = sum $ map snd xs
> in Branch freq (go ys) (go zs)
```

However, well-balanced trees might not be the best solution for this problem. It is generally known that few words in most natural languages are extremely commonly used (e.g. “the”, “a”, or in or case, “badger”) while most words are rarely used.

For our tree, it would make sense to have the more commonly used words closer to the root of the tree – in that case, it seems intuitive that the *expected* number of nodes visited to pick a random word will be lower.

It turns out that this idea exactly corresponds to a Huffman tree. In a Huffman tree, we want to minimize the expected code length, which equals the expected path length. Here, we want to minimize the expected number of nodes visited during a lookup – which is precisely the expected path length!

The algorithm to construct such a tree is surprisingly simple. We start out with a list of trees: namely, one singleton leaf tree for each element in our frequency list.

Then, given this list, we take the two trees which have the lowest total sums of frequencies (`sumFreqs`

), and join these using a branch node. This new tree is then inserted back into the list.

This algorithm is repeated until we are left with only a single tree in the list: this is our final frequency tree.

```
> huffmanTree :: Ord a => [(a, Int)] -> FreqTree a
> huffmanTree = go . map (\(x, f) -> Leaf f x) . uniqueFrequencies
> where
> go trees = case sortBy (comparing sumFreqs) trees of
> [] -> error "huffmanTree: Empty list"
> [ft] -> ft
> (t1 : t2 : ts) ->
> go $ Branch (sumFreqs t1 + sumFreqs t2) t1 t2 : ts
```

This yields the following tree for our example:

Although Huffman trees are well-studied, for our example, we only *intuitively* explained why the second approach is *probably* better. Let us see if we can justify this claim a bit more, and find out *how much* better it is.

The expected path length *L* of an item in a balanced tree can be very easily approached, since it is just a binary tree and we all know those (suppose *N* is the number of unique words):

However, if we have a tree we built using the `huffmanTree`

, it is not that easy to calculate the expected path length. We know that for a Huffman tree, the path length should approximate the entropy, which, in our case, gives us an approximation for the path length for item with a specified frequency *f*:

Where *F* is the total sum of all frequencies. If we assume that we know the frequency for every item, the expected path length is simply a weighted mean:

This is where it gets interesting. It turns out that the frequency of words in a natural language is a well-researched topic, and predicted by something called *Zipf’s law*. This law tells us that the frequency of an item *f* can be estimated by:

Where *s* characterises the distribution and is typically very close to 1 for natural languages. *H* is the generalised harmonic number:

If we substitute in the definition for the frequencies into the formula for the expected path length, we get:

This is something we can work with! If we plot this for *s = 1*, we get:

It is now clear that the expected path length for a frequency tree built using `huffmanTree`

is expected to be significantly shorter than a frequency tree built using `balancedTree`

, even for relatively small *N*. Yay! Since the algorithm now works, the conclusion is straightforward.

Lorem markdownum constitit foret tibi Phoebes propior poenam. Nostro sub flos auctor ventris illa choreas magnis at ille. Haec his et tuorum formae obstantes et viribus videret vertit, spoliavit iam quem neptem corpora calidis, in. Arcana ut puppis, ad agitur telum conveniant quae ardor? Adhuc arcu acies corpore amplexans equis non velamina buxi gemini est somni.

Thanks to Simon Meier, Francesco Mazzoli and some other people at Erudify for the interesting discussions about this topic!

]]>