Reasonably Polymorphic

review2

2026-08-24T23:26:00Z

Last time, we took a stroll down memory lane to review some ancient code I wrote, and see what/how I’d do things differently now. That was fun, and I have a new banger for us today.

Today’s example comes from the same place — a little vim-like text editor I was working on. Vim has this “repeat” operator which just does the same thing you did last time. It’s nice. Delete a word. Running repeat deletes another word. Kinda dinky in this example, but it can also rerun “increment every number in the next four paragraphs.”

Anyway, so that’s the feature I was trying to duplicate. But the action I was running might have done some IO, and I didn’t want to repeat the IO (because maybe the IO was to gather some input from the user, and repeating shouldn’t ask again.)

I was still high on my own supply of writing monads, so I approached this problem with a custom monad. The gist of the API was:

-- | A monad transformer adding the ability to record the results of IO actions
-- and later replay them.
data Again m a
instance Monad m => Monad (Again m)
instance MonadIO m => MonadIO (Again m)
instance MonadTrans Again

-- | Runs an action and records all of its sampled IO. Returns a action which
-- when invoked will use the recorded IO.
runAgain
    :: Monad m
    => Again m a
    -> m (m a)

-- | Marks an IO action to be memoized after its first invocation.
again
    :: ( MonadIO m
       , Typeable r
       )
    => IO r
    -> Again m r

I’m actually pretty impressed with past-me on this one. That’s a clean API, and the implementation was pretty cute.

newtype Again m a = Again
  { runAgain' :: RWST () [Dynamic] [Dynamic] m a
  }

once
    :: forall m r
     . ( MonadIO m
       , Typeable r
)
    => IO r
    -> Again m r
once action = do
    a <- dequeue >>= \case
        Just x  -> return . fromJust $ fromDynamic x
        Nothing -> liftIO action
    tell [toDyn a]
    return a
  where
    dequeue :: MonadState [r] m => m (Maybe r)
    dequeue = do
        get >>= \case
            []     -> return Nothing
            (x:xs) -> do
                put xs
                return $ Just x

The trick here is to keep MonadState [Dynamic] and a MonadWriter [Dynamic] instances around. This code uses the MonadState to pop off IO actions it’s already run, and the MonadWriter to keep track of new IO actions it needs to cache. The “magic” happens in runAgain, which runs it through once with an empty state, and then returns a new action with the MonadWriter results moved into the state for the next time around:

runAgain
    :: Monad m
    => Again m a
    -> m (m a)
runAgain action = do
    (a, w) <- evalRWST (runAgain' action) () []
    return $ do
        evalRWST (runAgain' action) () w
        return a

Simple. Clean. Elegant. Too bad it doesn’t actually work.

The following program crashes with an error coming from the unsafe use of fromJust in once:

oops :: Again (StateT Bool IO) ()
oops =
  -- Branch on the StateT
  lift get >>= \case
    -- The first time around...
    False -> do
      -- Cache a unit value
      once $ print ()
      -- Change the state value
      lift $ put True

    -- Since the state changed at the end of the first branch, we will take this
    -- branch the second time around...
    True -> do
      -- Calling 'once' the second time around gets its value from the cache,
      -- which has type @()@. But at this callsite, it ought to have type
      -- @Bool -> Bool@. Uh oh!
      f <- once $ pure not
      lift $ print ("uh oh!", f True)


ohNo :: IO ((), Bool)
ohNo = flip runStateT False $ do
  m <- runAgain oops
  m

The attack here comes from the fact that we can force the Again program down a different code path its second time around. And that second time, it encounters a call to once which has a different type than the one it cached. Thus, trying to reuse the cache leads to what is effectively a type error at runtime.

What actually went wrong here? The problem is that monads are too powerful. Since the only way to compose monads is via bind (m a -> (a -> m b) -> m b), we are forced to extend a monadic value of type m a by a function of type a -> m b. Which is to say that the “next thing to do” in a monadic computation is always going to be a function. And functions are completely opaque. So, once we’re given a monad, there’s simply no way to know what it’s going to do without actually running the continuation.

The problem arises from the fact that that continuation can invisibly branch. My Again monad was attempting to statically analyze the monadic computation, and cache the IO results in a queue. But as oops shows, it’s trivial to break this sort of static analysis. Because the branch is hidden inside of a function, and there’s no way to determine which branches a function didn’t take.

But I didn’t know that eleven years ago, so I give myself a pass on this one. Nevertheless, let’s tackle this problem with the wisdom of ages.

No More Monads

So if the problem with my previous implementation of Again is that it’s a monad, what options do we have? As it happens, there are two very nice options available to us here: arrows and selective applicative functors. We’ll discuss arrows for now, and come back to selectives.

Long time readers might remember a series on arrows from a few years back. But if you don’t, that’s OK; you’re still welcome here. A quick recap:

Arrows are a generalization of functions. Like functions, they take two type parameters (an input and an output). Like functions, they come with an identity arrow. They compose “end to end” just like functions do. These three properties are expressed as a Category superclass, which we usually call c and write infix:

class Category (c :: Type -> Type -> Type) where
  id  :: x `c` x
  (.) :: (y `c` z) -> (x `c` y) -> (x `c` z)

In addition to being categories, arrows also come with a means of transforming regular functions into arrows, and of mapping arrows over pairs:

class Category c => Arrow c where
  arr :: (x -> y) -> (x `c` y)
  (***) :: (x `c` x') -> (y `c` y') -> ((x, y) `c` (x', y'))

What’s neat about arrows is that their values are function-like things, rather than being actually functions. That means when we compose arrows, we compose values whose internals we get to choose. Which in turn, means that static analysis is possible again!

Attentive readers will notice that there isn’t actually any way for arrows-as-such to be able to branch. To gain that capability, they require an additional ArrowChoice, which equips them with the ability to lift arrows over Either:

class Arrow c => ArrowChoice c where
  (+++) :: (x `c` x') -> (y `c` y') -> (Either x y `c` Either x' y')

To wet our whistle, let’s write a little helper Arrow that shows that the composition of an applicative functor with an arrow is itself an arrow:

newtype Static m c x y = Static
  { unStatic :: m (c x y)
  }

The arrow instances for (Applicative m, Arrow c) => Static m c are the usual trick of using applicative functions to lift operations into the right place. For example, identity is just pure id, and composition isliftA2` of composition:

instance (Category c, Applicative m) => Category (Static m c) where
  id = Static $ pure id
  Static g . Static f = Static $ liftA2 (.) g f

We can do the same trick for arr and (***):

instance (Arrow c, Applicative m) => Arrow (Static m c) where
  arr = Static . pure . arr
  Static f *** Static g = Static $ liftA2 (***) f g

as well as for (+++):

instance (ArrowChoice c, Applicative m) => ArrowChoice (Static m c) where
  Static f +++ Static g = Static $ liftA2 (+++) f g

What’s nice about this Static construct we’ve built is that it gives us two degrees of freedom. We’re free to choose an arrow whose structure we’re going to reuse, and an underlying applicative functor (which can give us “static” effects as we’re building the underlying arrow.)

The idea here is that we can put the cache-building machinery inside of the applicative functor, but the cache-reading machinery inside of the underlying arrow.

Constructing Again, Again

It’s worth knowing about the Kleisli arrow:

newtype Kleisli m a b = Kleisli
  { runKleisli :: a -> m b
  }

instance Monad m => Category (Kleisli m)
instance Monad m => Arrow (Kleisli m)
instance Monad m => ArrowChoice (Kleisli m)

which says that any monadic bind function is itself an arrow. Implementing the instances yourself is a fun exercise if you’re new to this stuff. We can reuse Kleisli as our underlying arrow, which when you expand everything out, we get:

newtype Again m a b = Again
  { unAgain :: Static m (Kleisli m) a b
  }
  deriving newtype (Category, Arrow, ArrowChoice)

runAgain :: Monad m => Again m a b -> m (a -> m b)
runAgain = fmap runKleisli . unStatic . unAgain

What I think is particularly cool about this is that runAgain is just the composition of the newtype unwrappers, and yet its type is extremely reminiscent of my ten-year-ago implementation:

runAgain  -- the original
    :: Monad m
    => Again m a
    -> m (m a)

This is an instance of a more general principle, which is that the final “observation” you want to make of your type is always a good representation of that type. It’s not the only representation, but it’s always a reasonable choice. Appropriately enough, this is known as a final encoding.

Anyway. How can we implement once? By way of onceF:

onceF :: (MonadIO m, Ord a) => (a -> IO b) -> Again m a b
onceF m = Again $ Static $ do
  cache <- liftIO $ newIORef mempty
  pure $ Kleisli $ \a -> liftIO $ do
    cacheMap <- readIORef cache
    case M.lookup a cacheMap of
      Just b -> pure b
      Nothing -> do
        b <- m a
        modifyIORef' cache $ M.insert a b
        pure b

once :: MonadIO m => IO b -> Again m a b
once m = arr (const ()) >>> onceF (const m)

onceF works by constructing a cache :: IORef (Map a b) at the Static level. Each call to onceF gets a unique cache. Then we drop into the implementation of the Kleisli arrow (which recall happens at runtime.) Inside the Kleisli, we check to see if the map has a value at the requested a, and if so, return the cached b. If not, we run our function and cache it.

Since there’s no Dynamic tomfoolery here that is existentializing away our types, we don’t need to worry about the oops attack; Haskell’s type system guarantees we can’t construct such a thing.

Because Again isn’t a Monad, it can’t be a MonadIO either. But it’s nice to be able to provide the equivalent of liftIO:

againF :: MonadIO m => (a -> IO b) -> Again m a b
againF = Again . Static . pure . Kleisli . fmap liftIO

again :: MonadIO m => IO a -> Again m x a
again m = arr (const ()) >>> againF (const m)

So that completes our arrow-based implementation of Again. But there’s still something left undone.

Circling Back to Selectives

I said earlier that selective applicative functors would be an alternative approach to implementing Again. Selectives rightfully sit between Applicative and Monad in the functor hierarchy, but were discovered too late, and everyone was still kind of annoyed about having had just stuck Applicative into the hierarchy.

What, precisely is a selective functor? It’s a different solution to the problem of “monads are too powerful” which gives us a branching primitive to play with. Behold:

class Applicative f => Selective f where
  select :: f (Either a b) -> f (a -> b) -> f b

select says that you might have an a, in which case you must run the provided f (a -> b). But maybe you have a b, in which case you may run the effects of the f (a -> b). But nobody’s forcing you to.

Since there are still no raw function continuations to be seen here, we can use select to provide branching to our programs. But all of the branches can be identified statically, since we’re only operating on f values, again, whose internals we can control.

In fact, by aggressively nesting select calls, you can get back a version of monadic bind — so long as you have a finite number of select calls you’d need to make:

bindS
    :: (Selective f, Enum a, Bounded a, Eq a)
    => f a
    -> (a -> f b)
    -> f b

(the implementation of which is fun if you’re looking for a challenge)

Anyway, all of this is to say that we could have equally structured our Again as a selective functor rather than as an arrow! But ArrowChoice is at least as powerful as Selective, so given all of our hard work already, we can pull out a Selective instance for free.

What do I mean when I say “at least as powerful?” It means we can derive it for free, given an ArrowChoice instance. Behold, the GenericArrow newtype, which exists only for us to have something to attach some instances to.

newtype GenericArrow c x a = GenericArrow
  { unGenericArrow :: c x a
  }
  deriving newtype (Category, Arrow, ArrowChoice)

Here we use newtype deriving to say that if c is a category/arrow/arrowchoice, then GenericArrow c is too. But now we can show that having Arrow is enough to get Functor and Applicative instance:

instance Arrow c => Functor (GenericArrow c x) where
  fmap f c = arr f . c

instance Arrow c => Applicative (GenericArrow c x) where
  pure = arr . const
  liftA2 f x y = (x &&& y) >>> arr (uncurry f)

Then, given an ArrowChoice, we can get an implementation of select:

instance ArrowChoice c => Selective (GenericArrow c x) where
  select te tk = proc b -> do
    e <- te -< b
    case e of
      Left x -> do
        k <- tk -< b
        returnA -< k x
      Right y -> returnA -< y

Here we don’t have the option of choosing to invoke tk in the Right case. But that’s OK, because in Again, doing so would correspond to creating caches for branches that don’t need it.

Given all of this, we can now derive Functor up to Selective for Again:

newtype Again m a b = Again
  { unAgain :: Static m (Kleisli m) a b
  }
  deriving newtype (Category, Arrow, ArrowChoice)
  deriving (Functor, Applicative, Selective) via GenericArrow (Again m) a

which means that users can now choose between the arrow hierarchy and the functor hierarchy for how they’d like to think about building Again actions. And to nudge them even a little further, we can introduce something that looks like a monad transformer, removing the input parameter:

type AgainT m = Again m ()

runAgainT :: Monad m => AgainT m a -> m (m a)
runAgainT = fmap ($ ()) . runAgain

Clean. Tidy. Actually works this time around.

Code-Reviewing My First Monad Implementation

2026-08-21T23:50:00Z

I’ve been wanting to get back into the habit of blogging, and thought a fun project would be to go back through my old code and review it as the programmer I am now. So let’s do that.

Eleven years ago, I was so proud to written my first monad that I typed up a big olblog post about it. This seems like a fun thing to revisit, so let’s do it.

To save you the trouble of reading that ancient-ass blog post, here’s the gist. Given a big piece of state, that has many smaller stateful subcomponents, for example, a World is full of Buffers:

data World = World
  { wBuffers :: [Buffer]
  , wCurrent :: Int
  , wMode    :: Mode
  }

data Buffer = Buffer
  { bFilename :: FilePath
  , bContent  :: String
  }

my monad acted like StateT except that you can restrict the piece of the state you’re allowed to manipulate without losing the ability to look at the rest of the state.

In the blog post, this monad is called Jurisdiction, but at some point in the source code it got renamed to JailT. Cool name. Furthermore, the implementation changed rather dramatically from the blog post, so let’s chase the implementation as given. I’ll reproduce it here:

type RLens r s = Lens s s r r

newtype JailT s r m a =
    JailT
    { runJailT' :: Bool
                -> RLens r s
                -> s
                -> m (a, s, RLens r s, Bool) }
    deriving (Functor, Typeable)

instance (Applicative m, Monad m) => Applicative (JailT s r m) where
    pure x = JailT $ \v l s -> pure (x, s, l, v)
    (<*>)  = ap

instance (Applicative m, Monad m) => Monad (JailT s r m) where
    return   = pure
    ac >>= k = JailT $ \v l s ->
        if v
            then do
                (x, st', l', v') <- runJailT' ac v l s
                runJailT' (k x) v' l' st'
            else return (undefined, s, l, v)

Already there’s a lot to look at. The most immediate thing that strikes me is the formatting; now I’m very much a “use two spaces for indent” kind of guy — Haskell doesn’t provide many opportunities for natural linebreaks, and our horizontal space is much more limited than our vertical space. So don’t throw away your horizontal budget on initial spacing. It’s minor, but being an artisan means caring about the minor details.

newtype JailT s r m a = JailT
  { runJailT'
      :: Bool
      -> RLens r s
      -> s
      -> m (a, s, RLens r s, Bool)
  }
  deriving (Functor, Typeable)

Much nicer.

The other exciting thing to see in the earlier snippet is that this code comes from before the Functor-Applicative-Monad transition. Which is to say that it’s from the long long ago before Applicative was a superclass on Monad. There’s some history for you.

And then there is the elephant in the room. Whatever this Bool is being passed around by runJailT', the Monad instance branches on it and returns undefined when it’s False. What the hell is that???? Digging into the MonadPlus instance provides some insight:

instance (Applicative m, Monad m) => MonadPlus (JailT s r m) where
    mplus x y = JailT $ \v l s -> do
        x'@(xa, xs, xl, v') <- runJailT' x v l s
        if v'
           then return x'
           else runJailT' y v l s
    mzero = JailT $ \v l s -> return (undefined, s, l, False)

So mzero returns undefined and some False value, presumably which is there to try to warn someone that there’s an undefined floating around.

This is a stupid design. If you’re ever in the business of needing to store data-which-might-not-be-valid and a separate tag stating whether or not it’s valid, a much better design here would be to just use Maybe a instead of (a, Bool).

In fact, perhaps I realized this later on, because runJailT does exactly this logic:

runJailT :: (Functor m)
         => JailT s s m a
         -> s
         -> m (Maybe (a, s))
runJailT ac = fmap (\(a, s, _, v) ->
                            if v then Just (a, s) else Nothing)
                    . runJailT' ac True id

Let’s roll back a bit. The pivotal primitive of JailT is the aptly-named jail:

jail :: (Monad m)
     => RLens r' r
     -> JailT s r' m a
     -> JailT s r m a
jail l' m = JailT $ \v l s -> do
    (a, s', _, v') <- runJailT' m v (l . l') s
    return (a, s', l, v')

Pretty reasonable definition here. I’m not sure what the idea behind RLens being a flipped version of Lens' was for. The only odd choice here is that in the big tuple returned in jail, l gets passed along unchanged. We can tell from looking at it that l here is the current lens we’re looking at. But jail is the only primitive that changes the lens, and it takes a JailT as an argument. Which is all to say that there isn’t anything actually stateful going on with the RLens. So without looking any further, I’d bet dollars to donuts that this l getting returned is purely vestigial and serves absolutely no purpose. Which in turn means we should be able to chop it out of the definition of JailT.

Speaking of stupid anti-patterns, here’s another one:

into :: RLens a (Maybe a)
into = lens fromJust (const Just)

jailMaybe :: (Applicative m, Monad m)
          => RLens (Maybe r') r
          -> a
          -> JailT s r' m a
          -> JailT s r m a
jailMaybe l d m =
    (gets $ view l) >>= \case
        Just _  -> jail (l . into) m
        Nothing -> return d

This is horrendous for a few reasons. into is an unsafe lens that will crash if you try to read out of a Nothing. But then that behavior is guarded in jailMaybe by checking that it isn’t already nothing. Stupid.

The last function I want to point out is parole:

parole :: (Applicative m, Monad m)
       => a
       -> JailT s r m (Maybe a)
       -> JailT s r m a
parole d m = do
    this <- get
    m >>= \case
        Just a  -> return a
        Nothing -> put this >> return d

which… does… something. I guess it attempts to run a Maybe-valued JailT, and if it fails, unwinds the state and returns some default a. Rearing its ugly head here, however, is the ghost of the undefined nonsense from mzero. Note that if we invoke parole a mzero we will get a crash rather than the roll-back-and-default behavior that it promises on the tin.

So, all in all, I am not particularly impressed with my first monad. Here’s how I’d write it today.

First, I don’t think I’ve written a “control”-y sort of monad from scratch in the last five years. Whatever behavior you want is almost always just the composition of a few monad transformers. In this case, we have a Reader for the current lens, a State for the original state, and a Maybe to give us mzero semantics.

Since we want our state to roll-back when we take an alternative path, we must put MaybeT underneath our StateT.¹ This gives us the nice formulation of a JailT as:

newtype JailT s r m a = JailT
  { unJailT :: ReaderT (ALens' s r) (StateT s (MaybeT m)) a
  }

(we use ALens' s r here instead of Lens' s r since the latter requires -XImpredicativeTypes. Which happens to be turned on in the original implementation!)

Once nice thing about defining our monad as a newtype over a series of monad transformers, is that it allows us to newtype-derive all of the relevant instances:

  deriving newtype (Functor, Applicative, Monad, MonadIO, Alternative)

No implementation for such things is required, and therefore we know that the derived instances must be correct. Which means we have many fewer things to worry about.

I prefer to use unWhatever as my naming scheme for these newtypes, so that I can provide runWhatever as a more user-friendly function.

runJailT :: s -> Lens' s t -> JailT s t m a -> m (Maybe (a, s))
runJailT s l = runMaybeT . flip runStateT s . flip runReaderT l . unJailT

What’s also nice about using standard monad transformers for your implementation is that you can reuse all of their existing combinators. For example, to implement jail all we need to do is invoke withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a, which lets us change the type of the reader.

jail :: Lens' t u -> JailT s u m a -> JailT s t m a
jail ltu = JailT . withReaderT (\lst -> cloneLens lst . ltu) . unJailT

Notice here that I like to minimize my points without going point-free; jail as written is very legible, but writing it entirely pointfree is a crime against humanity:

-- don't do this!
jail = (JailT .) . (. unJailT) . withReaderT . flip ((.) . cloneLens)

Rather than implementing parole directly, we can note that it is the composition of two pieces — (1) attempt something, (2) return a default if it failed. Whenever you notice de-composition opportunities like this, take them!

We can write attempt, which is wildly general and doesn’t care one fig about jails or the legal system:

attempt :: (Alternative m, Monad m) => m (Maybe a) -> m a
attempt m = maybe empty pure =<< m

and then parole is merely

parole :: Monad m => a -> JailT s t m (Maybe a) -> JailT s t m a
parole a0 j =
  asum
    [ attempt j
    , pure a0
    ]

All in all, significantly nicer if you ask me. But I’m just a TV. Don’t take my word for it. Compare for yourself!

Original Implementation

An Algebraic Theory of Music

2026-01-02T14:27:00Z

In my last post, I was struggling towards an algebraic theory of music. This idea has been burning in my mind ever since, and I wanted to give some updates with where I’ve landed.

Differentiating Voices from Music

We begin by modeling a musical voice, which is, roughly speaking, the abstract version of a human voice. The voice can be doing one thing at a time, or can choose to not be doing anything.

Voices are modeled by step functions, which are divisions of the real line into discrete chunks. We interpret each discrete chunk as a note being played by the voice for the duration of the chunk.

This gives rise to a nice applicative structure that I alluded to in my previous post:

liftA2 f
  |---- a ----|-- b --|
  |-- x --|---- y ----|
=
  |- fax -|fay|- fby -|

where we take the union of the note boundaries in order to form the applicative. If either voice is resting, so too is the applicative. There is also an Alternative instance here, which chooses the first non-rest.

There is a similar monoidal structure here, where multiplication is given by “play these two things simultaneously,” relying on an underlying Semigroup instance for the meaning of “play these two things:”

instance Semigroup a => Semigroup (Voice a)
instance Semigroup a => Monoid (Voice a)

If either voice is resting, we treat its value as mempty, and can happily combine the two parts in parallel.

All of this gives rise to the following rich structure:

newtype Voice a = Voice { unVoice :: SF Time (Maybe a) }
  deriving stock
    (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Generic1)
  deriving newtype
    (Semigroup, Monoid)
  deriving
    Applicative
    via Compose (SF Time) Maybe

instance Filterable Voice
instance Witherable Voice
instance Alternative Voice

-- | Delay a voice by some amount of time.
delayV :: Time -> Voice a -> Voice a

From Voices to Music

Voices, therefore, give us our primitive notion of monophony. But real music usually has many voices doing many things, independently. This was a point in which I got stuck in my previous post.

The solution here, is surprisingly easy. Assign a Voice to each voice name:

newtype Music v a = Music
  { getVoices :: v -> Voice a
  }
  deriving stock
    (Functor, Generic, Functor)
  deriving newtype
    (Semigroup, Monoid)
  deriving (Applicative, Alternative)
    via Compose ((->) v) Voice

instance Profunctor Music

instance Finite v => Foldable (Music v)
instance Finite v => Traversable (Music v)
instance Filterable (Music v)
instance Finite v => Witherable (Music v)

We get an extremely rich structure here completely for free. Our monoid combines all voices in parallel; our applicative combines voices pointwise; etc. However, we also have a new Profunctor Music instance, whose characteristic lmap :: (b -> c) -> Music c a -> Music b a method allows us to trade lines between voices.

In addition to the in-parallel monoid instance, we can also define a tile product operator over Music v a, which composes things sequentially¹:

duration :: Music v a -> Time

(##) :: Semigroup a => Music v a -> Music v a -> Music v a
m@(Music m1) ## Music m2 =
    Music $ liftA2 (<>) m1 $ fmap (delayV $ duration m) m2

The Semigroup a constraint on (##) arises from the fact that the pieces of music might extend off to infinity in either direction (which pure @Voice must do), and we need to deal with that.

There are a few other combinators we care about. First, we can lift anonymous voices (colloquially “tunes”) into multi-part Music:

voice :: Eq v => v -> Music () a -> Music v a
voice v (Music sf) = Music $
  \case
    ((== v) -> True) -> sf ()
    _ -> mempty

and we can assign the same line to everyone:

everyone :: Music () a -> Music v a
everyone (Music m) = Music $ const $ m ()

Writing Lines

The primitives for building little tunes are

note :: Time -> a -> Music () a
rest :: Time -> Music () a

which you can then compose sequentially via (##), and assign to voices via voice.

Harmonic Constraints

One of the better responses to my last blog post was a link to Dmitri Tymoczko’s FARM 2024 talk.

There’s much more in this video than I can possibly due justice to here, but my big takeaway was that this guy is thinking about the same sorts of things that I am. So I dove into his work, and that lead to his quadruple hierarchy:

Voices move within chords, which move within scales, which move within macro-harmonies.

Tymoczko presents a T algebra which is a geometric space for reasoning about voice leadings. He’s got a lot of fun websites for exploring the ideas, but I couldn’t find an actual implementation of the idea anywhere, so I cooked one up myself.

The idea here is that we have some T :: [Nat] -> Type which describes a hierarchy of abstract scales moving with respect to one another. For example, the Western traditional of having triads move within the diatonic scale, which moves within the chromatic scale, would be represented as T '[3, 7, 12]. T forms a monoid, and has some simple generators that give rise to smooth voice leadings (chord changes.)

Having a model for smooth harmonic transformations means we can use it constructively. I am still working out the exact details here, but the rough shape of the idea is to build an underlying field of key changes (represented as smooth voice leadings in T '[7, 12]):

keyChanges :: Music () (T '[7, 12])

We can then make an underlying field of functional harmonic changes (chord changes), modeled as smooth voice leadings in T '[3, 7]:

chordChanges :: Music () (T '[3, 7])

Our voices responsible for harmony can now be written as values of type

harmonicVoices :: Music h (Set (T '[3]))

and we can use the applicative musical structure to combine the elements together:

{-# LANGUAGE ApplicativeDo #-}

extend :: T ns -> T (ns ++ ms)
sink   :: T ns -> T (n ': ns)

harmony :: Music h (Set (T '[3, 7, 12]))
harmony = do
  k <- everyone keyChanges
  c <- everyone chordChanges
  m <- harmonicVoices
  pure $ extend m <> extend c <> sink k

which we can later fmap out into concrete pitches. The result is that we can completely isolate the following pieces:

key changes
chord changes
how voices express the current harmony
the rhythms of all of the above

and the result is guaranteed to compose in a way that the ear can interpret as music. Not necessarily good music, but undeniably as music.

The type indices on T are purely for my book-keeping, and nothing requires them to be there. Which means we could also use the applicative structure to modulate over different sorts of harmony (eg, move from triads to seventh chords.)

Melody: Still an Open Question

I haven’t quite gotten a feel for melody yet; I think it’s probably in T '[7, 12], but it would be nice to be able to target chord tones as well. Please let me know in the comments if you have any insight here.

However, I have been thinking about contouring, which is the overall “shape” of a musical line. Does it go up, and peak in the middle, and then come down again? Or maybe it smoothly descends down.

We can use the discrete intervals intrinsic inside of Voices to find “reasonable” times to sample them. In essence this assigns a Time to each segment:

timed :: Music v a -> Music v (Time, a)

and we can then use these times to then sample a function Time -> b. This then allows us to apply contours (given as regular Real -> Real functions) to arbitrary rhythms. I currently have this typed as

contour :: Group a => a -> (Real -> Real) -> Music v () -> Music v a

where a ~ T something, and the outputted Reals get rounded to their nearest integer values. I’m not deeply in love with this type, but the rough idea is great—turn arbitrary real-valued functions into musical lines. This generalizes contouring, as well as scale runs.

Next Steps?

I’m writing all of this up because I go back to work on Monday and life is going to get very busy soon. I’m afraid I won’t be able to finish all of this!

The types above I’m pretty certain are relatively close to perfect. They seem to capture everything I could possibly want, and nothing I don’t want. Assuming I’m right about that, they must make up the basis of musical composition.

The next step therefore is to build musical combinators on top. One particular combinator I’ve got my eye on is some sort of general ~> “get from here to there” operator:

(~>) :: (Semigroup a, ???) => Music v a -> Music v a -> Music v a

which I imagine would bridge a gap between the end of one piece of music with beginning of another. I think this would be roughly as easy as moving each voice linearly in T space from where it was to where it needs to be. This might need to be a ternary operation in order to also associate a rhythmic pattern to use for the bridge.

But I imagine (~>) would be great for lots of dumb little musical things. Like when applied over the chord dimension, it would generate arpeggios. Over the scale dimension, it would generate runs. And it would make chromatic moves in the chroma dimension.

Choosing exactly what moves to make for Ts consisting of components in multiple axes might just be some bespoke order, or could do something more intelligent. I think the right approach would be to steal diagrams’ idea of an Envelope, and attach some relevant metadata to each Music. We could then write (~>) as a function of those envelopes, but I must admit I don’t quite know what this would look like.

As usual, I’d love any insight you have! Please leave it in the comments. Although I must admit I appreciate comments of the form “have you tried $X” much more than of the form “music is sublime and you’re an idiot for even trying this.”

Happy new year!

Strictly speaking, the tile product can also do parallel composition, as well as sychronizing composition, but that’s not super important right now.↩︎

Struggling Towards an Algebraic Theory of Music

2025-12-04T20:15:00Z

For the last few months, I’ve been trying to come up with a nice, denotational basis for what music is. But I’m running out of steam on the project, so I thought I’d write what I’ve figured out, and what I’ve tried but doesn’t work. Hopefully this will inspire someone to come tell me what I’m being stupid about and help get the whole process unstuck.

What Music Is Not

It’s tempting to gesticulate wildly, saying that music is merely a function from time to wave amplitudes, eg something of the form:

μ Music = Time -> Amplitude

While I think it’s fair to say that this is indeed the underlying denotation of sound, this is clearly not the denotation of music. For example, we can transpose a song up a semitone without changing the speed—something that’s very challenging without a great deal of in the waveform representation. And we can play a musical phrase backwards, which is probably impossible in a waveform for any timbral envelope.

Since we have now two examples of “reasonable to want to do” with musical objects, which cannot be expressed in terms of a function Time -> Amplitude, we must conceed that waveforms-over-time cannot be the denotation of music.

What Music Might Be

Music is obviously temporal, so keeping the “function from time” part seems relevant. But a function from time to what? As a first attempt:

data Note = Note Pitch Timbre Volume

μ Music = Time -> Set (Duration, Note)

which, for a given time, returns a set of notes starting at that time, and how long they ought to be played for. An immediate improvement would be to parameterize the above over notes:

μ (Music a) = Time -> Set (Duration, a)

It’s tempting to try to eliminate more of the structure here with our parametricity, but I was unable to do so. In contrapuntal music, we will want to be able to express two notes starting at the same moment, but ending at different times.

One alluring path here could to write monophonic voices, and combine them together for polyphony:

μ (Voice a) = {- something like -} Time -> (Duration, a)
μ (Music a) = Time -> Set (Voice a)

Such an encoding has many unfavorable traits. First, it just feels yucky. Why are there two layers of Time? Second, now I-as-a-composer need to make a choice of which voice I put each note in, despite the fact that this is merely an encoding quirk. So no, I don’t think this is a viable path forward.

So let’s return to our best contender:

μ (Music a) = Time -> Set (Duration, a)

This definition is trivially a monoid, pointwise over the time structure:

μ (Music a <> Music b) = Music (μ a <> μ b)
μ mempty = Music mempty

If we think about abstract sets here, rather than Data.Set.Set, such an object is clearly a functor. There are many possible applicatives here, but the pointwise zipper seems most compelling to me. Pictorally:

pure a
=
  |----- a ----forever...


liftA2 f
  |---- a ----|-- b --|
  |-- x --|---- y ----|
=
  |- fax -|fay|- fby -|

Such an applicative structure is quite nice! It would allow us to “stamp” a rhythm on top of a pure representation of a melody.

However, the desirability of this instance is a point against μ (Music a) = Time -> Set (Duration, a), since by Conal Elliott’s typeclass morphism rule, the meaning of the applicative here ought to be the applicative of the meaning. Nevertheless, any other applicative structure would be effecitvely useless, since it would require the notes on one side to begin at the same time as the notes on the other. To sketch:

-- bad instance!
liftA2 f (Music a) (Music b) =
    Music (liftA2 (\(d1, m) (d2, n) -> (d1 <> d2, f m n)) a b)

Good luck finding a musically meaningful pure for such a thing!

Ok, so let’s say we commit to the pointwise zippy instance as our applicative instance. Is there a corresponding monad? Such a thing would substitute notes with more music. My first idea of what to do with such a thing would be to replace chords with texture. For example, we could replace chords with broken chords, or with basslines that target the same notes.

Anyway, the answer is yes, there is such a monad. But it’s musically kinda troublesome. Assume we have the following function:

notes :: Music a -> [(Maybe Interval, a)]

which will convert a Music a into its notes and an optional temporal interval (optional because pure goes on forever.) Then, we can write our bind as:

m >>= f = flip foldMap (notes m) \case
  (Nothing, a) -> f a
  (Just (start, duration), a) ->
    offset start $ _ duration $ f a

where offset changes when a piece of music occurs. We are left with a hole of type:

Duration -> Music a -> Music a

whose semantics sure better be that it forces the given Music to fit in the alotted time. There are two reasonable candidates here:

scaleTo  :: Duration -> Music a -> Music a
truncate :: Duration -> Music a -> Music a

where scaleTo changes the local interpretation of time such that the entire musical argument is played within the given duration, and truncate just takes the first Duration’s worth of time. Truncate is too obviously unhelpful here, since the >>= continuation doesn’t know how much time it’s been given, and thus most binds will drop almost all of their resulting music.

Therefore we will go with scaleTo. Which satisfies all of the algebraic (monad) laws, but results in some truly mystifying tunes. The problem here is that this is not an operation which respects musical meter. Each subsequent bind results in a correspondingly smaller share of the pie. Thus by using only bind and mconcat, it’s easy to get a bar full of quarter notes, followed by a bar of sixty-fourth notes, followed by two bars full of of 13-tuplets. If you want to get a steady rhythm out of the whole thing, you need a global view on how many binds deep you’re ever going to go, and you need to ensure locally that you only produce a small powers-of-two number of notes, or else you will accidentally introduce tuplets.

It’s a mess. But algebraically it’s fine.

What Music Seems Like It Should Be

The above foray into monads seems tentatively promising for amateur would-be algorithmic composers (read: people like me.) But I have been reading several books on musical composition lately, and my big takeaway from them is just how damn contextual notes are.

So maybe this means we want more of a comonadic interface. One in which you can extend every note, by taking into account all of the notes in its local vicinity. This feels just as right as the monadic approach does, albeit in a completely different way. Being able to give a comonad instance for Music would require us to somehow reckon with having only a single a at any given time. Which appeals to my functional programmer soul, but again, I don’t know how to do it.

But imagine if we did have a comonadic instance. We could perform voice leading by inspecting what the next note was, and by futzing around with our pitch. We could do some sort of reharmonization by shifting notes around according to what else is happening.

But maybe all of this is just folly.

Music as it’s actually practiced doesn’t seem to have much of the functionaly-compositional properties we like—ie, that we can abstract and encapsulate. But music doesn’t appear to be like that! Instead, a happy melody takes a different character when played on major vs minor chords. Adding a dissonant interval can completely reconceptualize other notes.

It feels like a bit of a bummer to end like this, but I don’t really know where to go from here. I’ve worked something like six completely-different approaches over the last few months, and what’s documented here is the most promising bits and pieces. My next thought is that maybe music actually forms a sheaf, which is to say that it is a global solution that respects many local constraints.

All of this research into music has given me much more thoughts about music qua music which I will try to articulate the next time I have an evening to myself. Until then.

Arrows to Arrows, Categories to Queries

2025-10-14T14:31:00Z

I’ve had a little time off of work as of late, and been spending it in characteristically unwise ways. In particular, I’ve written a little programming language that compiles to SQL. I call it catlang. That’s not to say that I’ve written a new query language. It’s a programming language, whose compiler spits out one giant SELECT statement. When you run that query in postgres, you get the output of your program.

Why have I done this? Because I needed a funny compilation target to test out the actual features of the language, which is that its intermediary language is a bunch of abstract category theory nonsense. Which I’ll get to. But I’m sure you first want to see this bad boy in action.

Behold, the function that returns 100 regardless of what input you give it. But it does it with the equivalent of a while loop:

count : Int -> Int
count =
  x ->
    loop x
      i ->
        n <- join id id -< i
        z <- abs . (-) -< (n, 100)
        case z of
          inl _ -> inr . (+) -< (n, 1)
          inr _ -> inl -< n

If you’re familiar with arrow notation, you’ll notice the above looks kinda like one big proc block. This is not a coincidence (because nothing is a coincidence). I figured if I were to go through all of this work, we might as well get a working arrow desugarer out of the mix. But I digress; that’s a story for another time.

Anyway, what’s going on here is we have an arrow count, which takes a single argument x. We then loop, starting from the value of x. Inside the loop, we now have a new variable i, which we do some voodoo on to compute n—the current value of the loop variable. Then we subtract 100 from n, and take the absolute value. The abs function here is a bit odd; it returns Left (abs x) if the input was negative, and Right x otherwise. Then we branch on the output of abs, where Left and Right have been renamed inl and inr respectively. If n - 100 was less than zero, we find ourselves in the inl case, where we add 1 to n and wrap the whole thing in inr—which the loop interprets as “loop again with this new value.” Otherwise, n - 100 was non-negative, and so we can return n directly.

Is it roundabout? You bet! The obtuseness here is not directly a feature, I was just looking for conceptually simple things I could do which would be easy to desugar into category-theoretical stuff. Which brings us to the intermediary language. After desugaring the source syntax for count above, we’re left with this IL representation:

  id △ id
⨟ cochoice
    ( undist
    ⨟   ( (prj₁ ⨟ id ▽ id) △ id
          ⨟   ( prj₁ △ 100
              ⨟ (-)
              ⨟ abs
              )
            △ id
          ⨟ prj₁ △ id
          ⨟ dist
          ⨟   ( (prj₂ ⨟ prj₂ ⨟ prj₁) △ 1
              ⨟ (+)
              ⨟ inr
              )
            ▽ ( prj₂
              ⨟ prj₂
              ⨟ prj₁
              ⨟ inl
              )
        )
      △ prj₂
    ⨟ dist
    )
⨟ prj₁

We’ll discuss all of this momentarily, but for now, just let your eyes glaze over the pretty unicode.

The underlying idea here is that each of these remaining symbols has very simple and specific algebraic semantics. For example, A ⨟ B means “do A and pipe the result into B.” By giving a transformation from this categorical IL into other domains, it becomes trivial to compile catlang to all sorts of weird compilation targets. Like SQL.

You’re probably wondering what the generated SQL looks like. Take a peek if you dare.

Ungodly Compiled SQL

Theorems for Free Redux

2025-10-09T11:27:00Z

A reader recently got in touch with me regarding my 2017 blog post Review: Theorems for Free. He had some questions about the paper/my review, and upon revisiting it, I realized that I had no idea how the paper worked anymore.

So I decided to rehash my understanding, and came up with something much conceptually clearer about what is happening and why.

A quick summary of Theorems for Free:

For any polymorphic type, we can generate a law that must hold for any value of that type.

One the examples given is for the function length :: forall a. [a] -> Int, which states that forall f l. length (fmap f l) = length l—namely, that fmap doesn’t change the length of the list.

Theorems for Free gives a roundabout and obtuse set of rules for computing these free theorems. But, as usual, the clarity of the idea is obscured by the encoding details.

The actual idea is this:

Parametrically-polymorphic functions can’t branch on the specific types they are instantiated at.

Because of this fact, functions must behave the same way, regardless of the type arguments passed to them. So all of the free theorems have the form “replacing the type variables before calling the function is the same as replacing the type variables after calling the function.”

What does it mean to replace a type variable? Well, if we want to replace a type variable a with a', we will generate a fresh function f :: a -> a', and then stick it wherever we need to.

For example, given the function id :: a -> a, we generate the free theorem:

forall f a.
  f (id a) = id (f a)

or, for the function fromJust :: Maybe a -> a, we get:

forall f ma.
  f (fromJust ma) = fromJust (fmap f ma)

This scheme also works for functions in multiple type parameters. Given the function swap :: (a, b) -> (b, a), we must replace both a and b, giving the free theorem:

forall
    (f :: a -> a')
    (g :: b -> b')
    (p :: (a, b))
  swap (bimap f g p) = bimap g f (swap p)

In the special case where there are no type parameters, we don’t need to do anything. This is what’s happening in the length example given in the introduction.

Simple stuff, right? The obfuscation in the paper comes from the actual technique given to figure out where to apply these type substitutions. The paper is not fully general here, in that it only gives rules for the [] and (->) type constructors (if I recall correctly.) These rules are further obscured in that they inline the definitions of fmap, rather than writing fmap directly.¹ But for types in one variable, fmap is exactly the function that performs type substitution.

Perhaps this paper predates typeclasses? Very possible.↩︎

Analyzing API Design via Algebraic Laws

2025-05-05T07:33:00Z

The other day, someone asked:

Why doesn’t [the Data.Map function] unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a allow for different value types the way intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c does?

This is a very reasonable question, and it lead down an interesting rabbit hole of at the intersection of API design and efficient implementation.

To answer the original question, what would the type of a different value type of unionWith look like? It would be something in the flavor of:

unionWith :: (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c

But this new Maybe a -> Maybe b -> c parameter is somewhat lossy, in that it gives the impression that it could be called with Nothing Nothing as parameters, which doesn’t fit into the vibe of being a “union.”

So instead we could restrict that possibility by using These a b:

data These a b = This a | That b | These a b

unionWith :: (These a b -> c) -> Map k a -> Map k b -> Map k c

which seems reasonable enough.

But let’s take reasonableness out of the picture and start again from first principles. Instead let’s ask ourselves the deep philsophical question of what even IS a map?

A Map k v is a particularly efficient implementation of functions with type k -> Maybe v. But why is this Maybe here? It’s really only to encode the “default” value of performing a lookup. Nothing goes wrong if we generalize this to be Monoid v => k -> v. In fact, it helps us make sense of the right bias present in Data.Map, where we see:

lookup k (singleton k v1 <> singleton k v2) = Just v2

This equality is hard to justify under the normal understanding of Map k v being an encoding of a function k -> Maybe v. But under the general monoid interpretation, we get a nice semigroup homomorphism:

lookup k (m1 <> m2) = lookup k m1 <> lookup k m2

where the monoid in question has been specialized to be Last.

Of course, we also have a monoid homomorphism:

lookup k mempty = mempty

Let’s re-evaluate the original question in terms of this newly-generalized Map. Now that we’ve removed all of the unnecessary baggage of Maybe, we can again think about the desired type of unionWith:

unionWith
    :: (a -> b -> c)
    -> Map k a
    -> Map k b
    -> Map k c

which looks awfully familiar. This new type signature automatically resolves our original concerns about “what should we do if the key isn’t present?”—just call the function with mempty as a parameter!

We can give some semantics as to what unionWith ought to do again by relating it to the observation lookup. The relevant law here seems like it ought to be:

lookup k (unionWith f m n) = f (lookup k m) (lookup k n)

By choosing a degenerate function f, say, \_ _ -> nontrivial, where nontrivial is some value that is not mempty, we can see the beginnings of a problem:

  lookup k (unionWith f m n)
=
  f (lookup k m) (lookup k n)
= <let f = \_ _ -> nontrivial>
  nontrivial

Regardless of the key we lookup in our unionWithed Map, we need to get back nontrivial. How can we implement such a thing? I see only two ways:

explicitly associate every key in the map with nontrivial, or
keep nontrivial around as a default value in the map

#1 is clearly a non-starter, given that we want our Maps to be efficient encodings of functions, which leaves us with only #2. This is actually a pretty common construction, which stems immediately from the fact that a pair of monoids is itself a monoid. The construction would look something like this:

data Map k v = Map
  { defaultValue :: v
  , implementation :: Data.Map.Map k v
  }
  deriving stock Generic
  deriving (Semigroup, Monoid) via (Generically (Map k v))

unionWith
    :: (a -> b -> c)
    -> Map k a
    -> Map k b
    -> Map k c
unionWith f (Map def1 imp1) (Map def2 imp2) =
  Map (f def1 def2) (liftA2 f imp1 imp2)

Seems fine, right? The nail in the coffin comes from when we reintroduce our semigroup homomorphism:

lookup k (m1 <> m2) = lookup k m1 <> lookup k m2

Without loss of generalization, take m2 = pure nontrivial (where pure is just unionWith with a constant function.) This gives us:

lookup k (m1 <> pure nontrivial) = lookup k m1 <> nontrivial

Making this thing efficient is a further complication! We again have two options:

modify the value at every key by multiplying in nontrivial, or
finding a way of suspending this computation

#1 clearly requires $O(n)$ work, which again forces us to look at #2. But #2 seems very challenging, because the monoidal values we need to suspend need not span the entire Map. For example, consider a Map constructed a la:

((pure prefix1 <> ((pure prefix2 <> m) <> n)) <> (p <> pure suffix)

Representing this thing efficiently certainly isn’t impossible, but you’re not going to be able to do it on the balanced binary search trees that underlie the implementation of Data.Map.Map.

I find this quite an interesting result. I always assumed that Data.Map.Map (or at least, Data.Map.Monoidal.MonoidalMap) didn’t have an Applicative instance because it would require a Monoid constraint on its output—but that’s not the sort of thing we can express in Haskell.

But the analysis above says that’s not actually the reason! It’s that there can be no efficient implementation of Applicative, even if we could constrain the result.

What I find so cool about this style of analysis is that we didn’t actually write any code, nor did we peek into the implementation of Data.Map (except to know that it’s implemented as a balanced BST.) All we did was look at the obvious laws, instantiate them with degenerate inputs, and think about what would be required to to efficiently get the right answer.

Using Obscure Graph Theory to solve PL Problems

2025-05-04T08:05:00Z

Usually I write about solutions to problems I’ve worked out, but I’ve found myself increasingly becoming interesting in where solutions come from. Maybe it’s because I’ve been reading Boorstin’s excellent The Discoverers, which I’d strongly recommend.

Regardless of why, I thought I’d switch up the usual dance step today, and discuss what solving my most-recent-big-problem actually looked like, in terms of what I tried, where I looked, and what the timeline was.

The Problem

The problem is to serialize a program graph into a series of let-bindings. For example, given the following graph:

      +
    /   \
  f ---> g
  |     / \
  a     \ /
      expensive

which represents the program:

f a (g expensive expensive) + g expensive expensive

Unfortunately, this is a naive representation of the program, since it duplicates the work required to compute expensive four times, and g expensive expensive twice. Instead, we would prefer to generate the equivalent-but-more-efficient program:

let $0 = expensive
    $1 = g $0 $0
 in f a $1 + $1

This transformation is affectionately known as sharing, since it shares the computed answer whenever there is repeated work to be done.

So this is what we’re trying to do. Given the original graph, determine the best place to insert these let-bindings, for some reasonable definition of “best.” We can assume there are no side effects involved, so any place that an expression is well-scoped is an acceptable solution.

In order to understand some of my attempted solutions, it’s worth noting that our final solution should build something of type Expr, and the original graph is represented as a IntMap (ExprF Int). ExprF is the Base functor of Expr, with all of its self-references replaced by some type variable, in this case Int. Thus, the graph above looks much more like:

_ : IntMap (ExprF Int)
_ = IM.fromList
  [ (0, Apply "+" [1, 3])
  , (1, Apply "f" [2, 3]
  , (2, ...)  -- a
  , (3, Apply "g" [4, 4])
  , (4, ...)  -- expensive
  ]

The Original Solution

I spent over a year trying to solve this problem, with various mostly-working solutions during that time. My strategy here was to think really hard, write up some algorithm that seemed plausible, and then run it against our (small) battery of integration tests to make sure it got the same answer as before.

Why not property test it? I tried, but found it very challenging to implement well-typed generators that would reliably introduce shared thunks. But maybe there’s a different lesson to be learned here about writing good generators.

Anyway. For eight months, one of these think-really-hard algorithms fit the bill and didn’t give us any problems. It was a weird, bespoke solution to the problem that independetly kept track of all of the free variables in every graph fragment, and tried to let-bind a fragment as soon as we landed in a context where all of the free variables were in scope. It seemed to work, but it was extremely messy and unmaintainable.

At the time of writing, this sharing algorithm was the only source of let-binds in our entire language, which meant that it didn’t need to account for let-binds in the program.

Of course, that invariant eventually changed. We added a way in the source langauge to introduce lets, which meant my algorithm was wrong. And I had written it sufficiently long ago that I no longer remembered exactly why it worked. Which meant the theory of my program was lost, and thus that we ought to rewrite it.

Unfolding a Solution

I went back to the problem statement, and stared at it for a long time (back to the think-really-hard algorithm!) Upon staring at the problem, I realized that what I was really trying to do was determine where diamond patterns arose in the propgram graph.

Recall our original graph:

      +
    /   \
  f ---> g
  |     / \
  a     \ /
      expensive

If we redraw it such that g is on a different rank than f, then the two diamond patterns become much clearer:

      +
    /  \
  f     |
  | \   |
  a  \ /
      g
     / \
     \ /
   expensive

The insight I came up with is that if a node n is the source of a diamond, then we must let-bind the sink of the diamond immediately before inlining the definition of n.

This gives rise to the question of “how do we identify a diamond?” What we can do is give a mapping from each node to its reachable set of nodes. For example, in the above, we’d compute the map:

+         -> {+, f, a, g, expensive}
f         -> {f, a, g, expensive}
a         -> {a}
g         -> {g, expensive}
expensive -> {expensive}

Then when we go to inline a node, say, +, we can look for any nodes that are reachable via more than one of its immediate subterms. Since the immediate subterms of + are f and g, we can take the intersections of their reachable sets:

{f, a, g, expensive} union {g, expensive}

giving us

{g, expensive}

which is exactly the set of nodes that we need to perform sharing on. If you topologically sort this set, it gives you the order that you should perform your let bindings.

EXCEPT there’s a kink in the whole thing. What happens if one of the terms in this diamond contains free variables? In particular, we might have something like this:

      +
    /  \
  f     |
  | \   |
  a  \ /
      λx
     / \
     \ /
   expensive
      |
      x

This gives us an analogous set of reachable nodes when we look at +, but we obviously can’t lift expensive x above the lambda.

Resolving this problem required giving up on the notion of memoizing the entire reachable set of nodes, and to instead crawl the graph ensuring that everything is well-scoped.

Performance Woes

My algorithm looked fine, and, importantly, got the right answer in a reasonable amount of time on our (small) battery of integration tests. So I shipped it, commended myself on a job well done, and thought nothing more about it. For about a week, until a bug report came in saying that our compiler now seemed to hang on big programs.

Which was something I hadn’t noticed, since we didn’t have any big programs in our integration tests.

Damn!

Upon digging in to what exactly was so slow, I noticed that my algorithm was accidentally quadratic. I needed to fold over every node in the graph, and that required looking at the entire reachable set underneath it. I had put in some of the obvious safeguards, hoping that they would prune the search tree early, but it wasn’t enough sacrifice for the Great God of Asymptotes.

Did I mention that at this point in the story, having this algorithm working fast was on the critical path of the company? Everybody else was blocked on me figuring this out. Talk about pressure!

Anyway. You’ll notice above that in my description of the algorithm, everything sounds fine. But the juice is in the details, as the common saying goes. Computing reachability isn’t quite the right thing to be using here, as it gave us the wrong answer for the lambda example above. Which is unfortunate because reachability is something we can do in linear time.

And then when reachability didn’t work, I just threw away the fast performance and hoped my bespoke algorithm would do the job. My only redemption comes from the fact that at least it got the right answer, even if it did so very slowly.

Finding the Kernel

Back to the drawing board.

Whenever I have graph theory problems, I call up my boy Vikrem. He’s good at nerd stuff like this.

We rubberducked the problem, and tried to reframe the problem in the language of graph theory. We had a Merkiv–Maguire moment where we indepdently realized that the goal was somehow related to finding the lowest common ancestor (LCA) of a node.

Which is to say, roughly, that we are looking for forks in the diamond diagram. Which we already knew, but it was nice to have some language for.

Our new problem is that LCA is defined only over trees. There are some extensions to DAGs, but none of them seem to be particularly well founded. However, searching for exactly that brought me to this stackoverflow question, where nestled in the comments is someone suggesting that the poster isn’t looking for LCA, but instead for a related notion the lowest single common ancestor. LSCA is defined in a 2010 paper New common ancestor problems in trees and directed acyclic graphs.

The standard definition of LCA(x, y) = l is that “l is an ancestor of x and of y, and that no descendent of l has this property.”

But the definition of LSCA(x, y) = l is that “l lies on all root-to-x paths, and that l lies on all root-to-y paths, and that no descendent of l has this property.”

The distinction between the two is easily seen in the following graph:

Under the standard definition, LCA is not uniquely defined for DAGs. That is, LCA(3, 4) = {1, 2}. But neither 1 nor 2 lies on all paths from the root. Under LSCA therefore we get LSCA(3, 4) = 0, which is the obviously-correct place to let-bind 3 and 4.

The paper gives a preprocessing scheme for computing LSCA by building a “lowest single ancestor” (LSA) tree. The LSA of a node is the LSCA of all of its in-edges. This definition cashes out to mean “the most immediate diamond above any node.” Finally! This is exactly what we’re looking for, since this is where we must insert our let-bindings! Even better, the paper gives us an algorithm for computing the LSA tree in linear time!

The First Implementer

Of course, I’m lazy and would prefer not to implement this thing. So instead I searched on hackage for lsca, and found nothing. But then I searched for lca and found that, like always, Ed Kmett was 13 years ahead of me.

The lca package implements an $O(log n)$ algorithm for computing the LCA of any two nodes in a graph. Which is very convenient for me, since the LSCA algorithm requires being able to do this.

Time to roll up the sleeves and get cracking I suppose.

The paper was surprisingly straightforward, and my first attempt implemented the (imperative) algorithms as given (imperatively.) The first step is to do a topological sort on the DAG in order to know in which order one ought to unfold the LSA tree.

But as is so often the case, this topological sort isn’t actually relevant to the algorithm; it’s just an encoding detail of expressing the algorithm imperatively. But you don’t need that when you’ve got laziness on your side! Instead you can just tie the know and do something cool like this:

lsaTree :: Ord v => Map v (Set v) -> Map v (Path v)
lsaTree input = fix $ \result -> M.fromList $ do
  (node, parents) <- M.toList input
  let parentResults = fmap (result M.!) parents
  ...

Notice how we use fix to bind the eventual result of the final computation. Then we can chase pointers by looking them up in result—even though it’s not yet “computed.” Who cares what order the computer does it in. Why is that a thing I should need to specify?

Anyway. The exact details of implementing LSA are not particularly important for the remainder of this blog post. If you’re interested, you can peep the PR, which is delightfully small.

Tying It All Back Together

Equipped with my LSA tree, I was now ready to go back and solve the original problem of figuring out where to stick let-bindings. It’s easy now. Given the original program graph, find the LSA for each node. The LSA is the place you should insert the let binding.

So given the map of nodes to their LSAs, invert that map and get back a map of nodes to descendents who have this node as an LSA. Now when you go to inline a node, just look up everything in this map and inline it first.

It turns out to be a very elegant solution. It’s one third of the length of my horrible ad-hoc implementations, and it runs in linear time of the number of nodes in the graph. All in all, very good.

More often than I’m comfortable about, people will ask me how I can have so many good ideas. And what I like about this story is that it’s pretty typical of how I actually “have” “good” ideas. I’m reminded of the fact that luck favors the prepared mind. Attentive readers will notice that none of this process was due to brilliance on my part. I happened to know Vikrem who’s a genius. Together we pulled at some ancient graph theory strings and remembered a fact that someone else had thought important to teach us. That wasn’t actually the right path, but it lead us to stackoverflow where someone had linked to a relevant paper. I implemented the paper using a library that someone else had done the heavy lifting on, and simplified the implementation using this knot-tying trick I picked up somewhere along the way.

Also, I’m just really pleased that the solution came from trying to reverse engineer the relevant graph-theory search terms. Maybe that’s the actual takeaway here.

Bidirectional Instance Contexts

2025-02-15T02:15:00Z

Just a quick one today, but I wanted to point out a little trick you can do with Haskell’s typeclass inference.

Imagine we have some little class, the details of which matter not in the least:

type Foo :: Type -> Constraint
class Foo a where
  ...

We can give some instances of this type:

instance Foo Int where ...
instance Foo Bool where ...
instance Foo () where ...

Regular, everyday stuff. But the instances for type constructors are more interesting, because they come with an instance context:

instance (Foo a, Foo b) => Foo (a, b) where ...

Then, of course, if we know both Foo a and Foo b, we can infer Foo (a, b). To make this fact overwhelmingly explicit, we can reify the usual constraint-solving logic by using the Dict type, and thus the following program will typecheck:

import Data.Constraint

forwards
  :: Dict (Foo a)
  -> Dict (Foo b)
  -> Dict (Foo (a, b))
forwards Dict Dict = Dict

Perhaps tipped off by the name here, the gentle reader is asked to notice the asymmetry here, since the converse program will not typecheck:

backwards
  :: Dict (Foo (a, b))
  -> (Dict (Foo a), Dict (Foo b))
backwards Dict = (Dict, Dict)

But why should it not typecheck?¹ Recall from the relevant instance definition that these instances must, in fact, exist:

instance (Foo a, Foo b) => Foo (a, b)

As a testament to just how good GHC is, we can support this bidirectionality via a minor tweak to the definition of class and its instances.

The trick is to add an associated type family to Foo, and to use it as a superclass constraint:

type Foo :: Type -> Constraint
class Evidence a => Foo a where
  type Evidence a :: Constraint
  type Evidence a = ()
  ...

Because we’ve given a default implementation of the type family, our existing simple instances work as before:

instance Foo Int where ...
instance Foo Bool where ...
instance Foo () where ...

with the only change required coming from the type constructor instances:

instance (Foo a, Foo b) => Foo (a, b) where
  type Evidence (a, b) = (Foo a, Foo b)
  ...

or, if we you want to be cute about it:

instance Evidence (a, b) => Foo (a, b) where
  type Evidence (a, b) = (Foo a, Foo b)
  ...

By sticking Evidence into the superclass constraint, GHC knows that this dictionary is always available when you’ve got a Foo dictionary around. And our earlier backwards program now typechecks as expected.

This is all available in a play session if you’d like to fool around with it.

Rhetorical question. I don’t want to hear about orphans or overlapping instances or whatever.↩︎

Use Monoids for Construction

2025-01-24T09:35:00Z

There’s a common anti-pattern I see in beginner-to-intermediate Haskell programmers that I wanted to discuss today. It’s the tendency to conceptualize the creation of an object by repeated mutation. Often this takes the form of repeated insertion into an empty container, but comes up under many other guises as well.

This anti-pattern isn’t particularly surprising in its prevalence; after all, if you’ve got the usual imperative brainworms, this is just how things get built. The gang of four “builder pattern” is exactly this; you can build an empty object, and setters on such a thing change the state but return the object itself. Thus, you build things by chaning together setter methods:

Foo myFoo = new Foo().setBar().setQux(17).setZap(true);

Even if you don’t ascribe to the whole OOP design principle thing, you’re still astronomically likely to think about building data structures like this:

Doodad doodad = new Doodad;
foreach (Widget widget in widgets) {
  doodad.addWidget(widget);
}

To be more concrete, maybe instead of doodads and widgets you have BSTs and Nodes. Or dictionaries and key-value pairs. Or graphs and edges. Anywhere you look, you’ll probably find examples of this sort of code.

Maybe you’re thinking to yourself “I’m a hairy-chested functional programmer and I scoff at patterns like these.” That might be true, but perhaps you too are guilty of writing code that looks like:

foldr
    (\(k, v) m -> Map.insert k v m)
    Map.empty
  $ toKVPairs something

Just because it’s dressed up with functional combinators doesn’t mean you’re not still writing C code. To my eye, the great promise of functional programming is its potential for conceptual clarity, and repeated mutation will always fall short of the mark.

The complaint, as usual, is that repeated mutation tells you how to build something, rather than focusing on what it is you’re building. An algorithm cannot be correct in the absence of intention—after all, you must know what you’re trying to accomplish in order to know if you succeeded. What these builder patterns, for loops, and foldrs all have in common is that they are algorithms for strategies for building something.

But you’ll notice none of them come with comments. And therefore we can only ever guess at what the original author intended, based on the context of the code we’re looking at.

I’m sure this all sounds like splitting hairs, but that’s because the examples so far have been extremely simple. But what about this one?

cgo :: (a -> (UInt, UInt)) -> [a] -> [NonEmpty a]
cgo f = foldr step []
  where
    step a [] = [pure a]
    step a bss0@((b :| bs) : bss)
      | let (al, ac) = f a
      , let (bl, bc) = f b
      , al + 1 == bl && ac == bc
            = (a :| b : bs) : bss
      | otherwise = pure a : bss0

which I found by grepping through haskell-language-server for foldr, and then mangled to remove the suggestive variable names. What does this one do? Based solely on the type we can presume it’s using that function to partition the list somehow. But how? And is it correct? We’ll never know—and the function doesn’t even come with any tests!

It’s Always Monoids

The shift in perspective necessary here is to reconceptualize building-by-repeated-mutation as building-by-combining. Rather than chiseling out the object you want, instead find a way of gluing it together from simple, obviously-correct pieces.

The notion of “combining together” should evoke in you a cozy warm fuzzy feeling. Much like being in a secret pillow form. You must come to be one with the monoid. Once you have come to embrace monoids, you will have found inner programming happiness. Monoids are a sacred, safe place, at the fantastic intersection of “overwhelming powerful” and yet “hard to get wrong.”

As an amazingly fast recap, a monoid is a collection of three things: some type m, some value of that type mempty, and binary operation over that type (<>) :: m -> m -> m, subject to a bunch of laws:

∀a. mempty <> a = a = a <> mempty
∀a b c. (a <> b) <> c = a <> (b <> c)

which is to say, mempty does nothing and (<>) doesn’t care where you stick the parentheses.

If you’re going to memorize any two particular examples of monoids, it had better be these two:

instance Monoid [a] where
  mempty = []
  a <> b = a ++ b

instance (Monoid a, Monoid b) => Monoid (a, b) where
  mempty = (mempty, mempty)
  (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2)

The first says that lists form a monoid under the empty list and concatenation. The second says that products preserve monoids.

The list monoid instance is responsible for the semantics of the ordered, “sequency” data structures. That is, if I have some sequential flavor of data structure, its monoid instance should probably satisfy the equation toList a <> toList b = toList (a <> b). Sequency data structures are things like lists, vectors, queues, deques, that sort of thing. Data structures where, when you combine them, you assume there is no overlap.

The second monoid instance here, over products, is responsible for pretty much all the other data structures. The first thing we can do with it is remember that functions are just really, really big product types, with one “slot” for every value in the domain. We can show an isomorphism between pairs and functions out of booleans, for example:

from :: (Bool -> a) -> (a, a)
from f = (f False, f True)

to :: (a, a) -> (Bool -> a)
to (a, _) False = a
to (_, a) True  = a

and under this isomorphism, we should thereby expect the Monoid a => Monoid (Bool -> a) instance to agree with Monoid a => Monoid (a, a). If you generalize this out, you get the following instance:

instance Monoid a => Monoid (x -> a) where
  mempty = \_ -> mempty
  f <> g = \x -> f x <> g x

which combines values in the codomain monoidally. We can show the equivalence between this monoid instance and our original product preservation:

  from f <> from g
= (f False,  f True) <> (g False, g True)
= (f False <> g False, f True <> g True)
= ((f <> g) False, (f <> g) True)
= from (f <> g)

and

  to (a11, a12) <> to (a21, a22)
= \x -> to (a11, a12) x <> to (a21, a22) x
= \x -> case x of
    False -> to (a11, a12) False <> to (a21, a22) False
    True  -> to (a11, a12) True  <> to (a21, a22) True
= \x -> case x of
    False -> a11 <> a21
    True  -> a12 <> a22
= \x -> to (a11 <> a21, a12 <> a22) x
= to (a11 <> a21, a12 <> a22)

which is a little proof that our function monoid agrees with the preservation-of-products monoid. The same argument works for any type x in the domain of the function, but showing it generically is challenging.

Anyway, I digresss.

The reason to memorize this Monoid instance is that it’s the monoid instance that every data structure is trying to be. Recall that almost all data structures are merely different encodings of functions, designed to make some operations more efficient than they would otherwise be.

Don’t believe me? A Map k v is an encoding of the function k -> Maybe v optimized to efficiently query which k values map to Just something. That is to say, it’s a sparse representation of a function.

From Theory to Practice

What does all of this look like in practice? Stuff like worrying about foldr is surely programming-in-the-small, which is worth knowing, but isn’t the sort of thing that turns the tides of a successful application.

The reason I’ve been harping on about the function and product monoids is that they are compositional. The uninformed programmer will be surprised by just far one can get by composing these things.

At work, we need to reduce a tree (+ nonlocal references) into an honest-to-goodness graph. While we’re doing it, we need to collect certain nodes. And the tree has a few constructors which semantically change the scope of their subtrees, so we need to preserve that information as well.

It’s actually quite the exercise to sketch out an algorithm that will accomplish all of these goals when you’re thinking about explicit mutation. Our initial attempts at implementing this were clumsy. We’d fold the tree into a graph, adding fake nodes for the Scope construcotrs. Then we’d filter all the nodes in the graph, trying to find the ones we needed to collect. Then we’d do a graph traversal from the root, trying to find these Scope nodes, and propagating their information downstream.

Rather amazingly, this implementation kinda sorta worked! But it was slow, and took $O(10k)$ SLOC to implement.

The insight here is that everything we needed to collect was monoidal:

data Solution = Solution
  { graph :: Graph
  , collectedNodes :: Set Node
  , metadata :: Map Node Metadata
  }
  deriving stock (Generic)
  deriving (Semigroup, Monoid) via Generically Solution

where the deriving (Semigroup, Monoid) via Generically Solution stanza gives us the semigroup and monoid instances that we’d expect from Solution being the product of a bunch of other monoids.

And now for the coup de grace: we hook everything up with the Writer monad. Writer is a chronically slept-on type, because most people seem to think it’s useful only for logging, and, underwhelming at doing logging compared to a real logger type. But the charm is in the details:

instance Monoid w => Monad (Writer w)

Writer w is a monad whenever w is a monoid, which makes it the perfect monad for solving data-structure-creation problems like the one we’ve got in mind. Such a thing gives rise to a few helper functions:

collectNode :: MonadWriter Solution m => Node -> m ()
collectNode n = tell $ mempty { collectedNodes = Set.singleton n }

addMetadata :: MonadWriter Solution m => Node -> Metadata -> m ()
addMetadata n m = tell $ mempty { metadata = Map.singleton n m }

emitGraphFragment :: MonadWriter Solution m => Graph -> m ()
emitGraphFragment g = tell $ mempty { graph = g }

each of which is responsible for adding a little piece to the final solution. Our algorithm is thus a function of the type:

algorithm
  :: Metadata
  -- ^ the current scope
  -> Tree
  -- ^ the tree we're reducing
  -> Writer Solution Node
  -- ^ our partial solution, and the node corresponding to the root of the tree

which traverses the Tree, recursing with a different Metadata whenever it comes across a Scope constructor, and calling our helper functions as it goes. At each step of the way, the only thing it needs to return is the root Node of the section of the graph it just built, which recursing calls can use to break up the problem into inductive pieces.

This new implementation is roughly 20x smaller, coming in at @O(500)@ SLOC, and was free of all the bugs we’d been dilligently trying to squash under the previous implementation.

Chalk it down to another win for induction!