A Fast Bytecode VM for Arithmetic: The Virtual Machine

In this series of posts, we write a fast bytecode compiler and a virtual machine for arithmetic in Haskell. We explore the following topics:

• Parsing arithmetic expressions to Abstract Syntax Trees (ASTs).
• Unit testing for our parser.
• Interpreting ASTs.
• Compiling ASTs to bytecode.
• Disassembling and decompiling bytecode.
• Unit testing for our compiler.
• Property-based testing for our compiler.
• Efficiently executing bytecode in a virtual machine (VM).
• Unit testing and property-based testing for our VM.
• Benchmarking our code to see how the different passes perform.
• All the while keeping an eye on performance.

In this final post, we write the virtual machine that executes our bytecode, and benchmark it.

This post was originally published on abhinavsarkar.net.

This post is part of the series: A Fast Bytecode VM for Arithmetic.

1. The Parser
2. The Compiler
3. The Virtual Machine (you are here)

Introduction

Bytecode Virtual Machines (VMs) are known to be faster than AST-walking interpreters. That’s why many real-world programming languages these days are implemented with bytecode VMs, for example, Java, Python, PHP, and Raku. The reason is partially, the flat and compact nature of bytecode itself. But VMs also have a few other tricks up their sleeves that make them highly performant. In this post, we write a VM for our arithmetic expression language, and explore some of these performance tricks.

But first, we need to finish a pending task.

Testing the Compiler

We wrote some unit tests for our compiler in the last post, but unit tests cover only the cases we can think of. A compiler has to deal with any input, and with just unit tests we cannot be sure of its correctness.

To test our compiler and other components for correctness, we use the QuickCheck library. QuickCheck is a Property-based Testing framework. The key idea of property-based testing is to write properties of our code that hold true for any input, and then to automatically generate a large number of arbitrary inputs and make sure that the properties are indeed true for them¹². Since we are writing an arithmetic expression parser/compiler/VM, we generate arbitrary expression ASTs, and use them to assert certain invariants of our program.

With QuickCheck, we write generators for the inputs for our tests. These generators are composable just like parser combinators are. We use the library provided generators to write small generators that we combine to create larger ones. Let’s start:

numGen :: Q.Gen Expr
numGen = Num <$> Q.arbitrary

varGen :: Set.Set Ident -> Q.Gen Expr
varGen vars = Var <$> Q.elements (Set.toList vars)
 
identGen :: Q.Gen Ident
identGen =
  mkIdent
    <$> ( (:)
            <$> Q.elements lower
            <*> Q.resize 5 (Q.listOf1 $ Q.elements validChars)
        ) `Q.suchThat` (not . isReservedKeyword . BSC.pack)
  where
    lower = ['a' .. 'z']
    validChars = lower <> ['A' .. 'Z']

First come the basic generators:

• numGen generates number expressions by using QuickCheck’s built-in arbitrary function.
• varGen generates variable expressions by choosing from the set of passed valid variable names.
• identGen generates valid identifiers from combinations of letters a—z and A—Z, and discarding ones that are reserved keywords.

Moving on to composite generators:

binOpGen :: Set.Set Ident -> Int -> Q.Gen Expr
binOpGen vars size =
  BinOp
    <$> Q.chooseEnum (Add, Div)
    <*> exprGen vars (size `div` 2)
    <*> exprGen vars (size `div` 2)

letGen :: Set.Set Ident -> Int -> Q.Gen Expr
letGen vars size = do
  x <- identGen
  let vars' = Set.insert x vars
  Let x <$> exprGen vars (size `div` 2) <*> exprGen vars' (size `div` 2)

exprGen :: Set.Set Ident -> Int -> Q.Gen Expr
exprGen vars size
  | size < 5 = Q.frequency [(4, Q.oneof baseGens), (1, Q.oneof compositeGens)]
  | otherwise = Q.frequency [(1, Q.oneof baseGens), (4, Q.oneof compositeGens)]
  where
    baseGens = numGen : [varGen vars | not $ Set.null vars]
    compositeGens = [binOpGen vars size, letGen vars size]

• binOpGen generates binary expressions with arbitrary binary operations. It recursively calls exprGen to generate the operands. The size parameter controls the complexity of the generated expressions, and we half the size of operands (and so on recursively) so that we don’t end up with infinitely large expressions.

• letGen generates Let expressions by generating an identifier, and then generating the assignment and body expressions recursively. We do the same trick of halving sizes here as well. Notice that the assignment is generated with the passed variable names in scope, whereas the body is generated with the new identifier added to the scope.

• exprGen uses the above generators to generate all kinds of expressions. At smaller sizes, it prefers to generate base expressions, while at larger sizes, it prefers composite ones. Due to the careful recursive halving of size in composite generators, we end up with expressions of finite sizes.

Finally, we have some instances of QuickCheck’s Arbitrary type class to tie everything together:

instance Q.Arbitrary Expr where
  arbitrary = Q.sized $ exprGen Set.empty
  shrink = Q.genericShrink

instance Q.Arbitrary Ident where
  arbitrary = identGen

instance Q.Arbitrary Op where
  arbitrary = Q.chooseEnum (Add, Div)

We can apply them in GHCi:

> :set -XTypeApplications
> Q.sample $ Q.arbitrary @Expr
0
((let jgSg = 2 in (-2 - -2)) + -2)
2
(0 / 1)
(-11 / -13)
((let kpuS = 10 in 31) + (let jChmZV = -12 in jChmZV))
((54 * -55) * (let ohLSk = 29 in -45))
(-102 - (-119 * -125))
(-234 - (32 / -217))
(let kVrB = (-261 * 238) in ((let qdz = 228 in 347) + 18))
(let uMMdXH = ((let ePUi = 842 in ePUi) - (let zrkM = (let vwH = ((9 + -987) / -487) in (let ylKowr = vwH in vwH)) in zrkM)) in (((uMMdXH / -836) / uMMdXH) - (let qkK = uMMdXH in qkK)))

Notice that the generated samples increase in complexity. With the generators in place, we define our properties next. Let’s test our parser first:

prop_print_ast_then_parse_returns_same_ast :: Spec
prop_print_ast_then_parse_returns_same_ast =
  prop "Property: Print AST then parse returns same AST" $ \expr ->
    parse (BSC.pack $ show expr) == Right expr

This property is a simple round-trip test for the parser and printer: we parse the string representation of a generated expression, and assert that it gives back the same expression.

The second property is a more involved round-trip test for the compiler and decompiler:

prop_disassemble_bytecode_then_decompile_then_compile_returns_same_bytecode :: Spec
prop_disassemble_bytecode_then_decompile_then_compile_returns_same_bytecode =
  prop ( "Property: Disassemble bytecode then decompile then compile"
         <> " returns same bytecode" ) $ \expr ->
    case compile (sizedExpr expr) of
      Left _ -> Q.discard
      Right bytecode ->
        (disassemble bytecode >>= (decompile >>> fmap sizedExpr) >>= compile)
          == Right bytecode

This asserts that compiling an expression, then disassembling and decompiling it, and finally compiling it again should result in the original bytecode³.

This requires a helper function to get the size of an expression:

sizedExpr :: Expr -> SizedExpr
sizedExpr expr = case expr of
  Num _ -> (expr, 3)
  Var _ -> (expr, 2)
  BinOp _ a b -> (expr, snd (sizedExpr a) + snd (sizedExpr b) + 1)
  Let _ a b -> (expr, snd (sizedExpr a) + snd (sizedExpr b) + 1)

We run these tests in a later section. This ends our short detour.

The Virtual Machine

Now for the main event: the virtual machine. Our VM is a stack-based machine that operates on a stack of values and executes the compiled bytecode. Our goal is to be as fast as possible. For a quick reminder, these are our Opcodes:

data Opcode
  = OPush !Int16        -- 0
  | OGet !Word8         -- 1
  | OSwapPop            -- 2
  | OAdd                -- 3
  | OSub                -- 4
  | OMul                -- 5
  | ODiv                -- 6
  deriving (Show, Read, Eq, Generic)

And now, the heart of the VM:

interpretBytecode :: Bytecode -> Result Int16
interpretBytecode = interpretBytecode' defaultStackSize

interpretBytecode' :: Int -> Bytecode -> Result Int16
interpretBytecode' stackSize bytecode = runST $ runExceptT $ do
  stack <- PA.newPinnedPrimArray stackSize
  sp <- go 0 0 stack
  checkStack InterpretBytecode stackSize sp
  PA.readPrimArray stack 0
  where
    !size = BS.length bytecode

    go sp ip _ | ip == size = pure sp
    go !sp !ip stack = do
      let opcode = readInstr bytecode ip
      if
        | sp >= stackSize -> throwInterpretError "Stack overflow"
        | sp < 0 -> throwInterpretError "Stack underflow"
        | sp < 2 && opcode >= 2 -> throwInsufficientElementsError
        | opcode == 0 && ip + 2 >= size -> throwIPOOBError $ ip + 2
        | opcode == 1 && ip + 1 >= size -> throwIPOOBError $ ip + 1
        | otherwise -> case opcode of
            0 -> do                 -- OPush
              PA.writePrimArray stack sp $ readInstrArgInt16 bytecode ip
              go (sp + 1) (ip + 3) stack
            1 -> do                 -- OGet
              let i = fromIntegral $ readInstrArgWord8 bytecode ip
              if i < sp
                then do
                  PA.copyMutablePrimArray stack sp stack i 1
                  go (sp + 1) (ip + 2) stack
                else throwInterpretError $
                  "Stack index " <> show i <> " out of bound " <> show (sp - 1)
            2 -> do                 -- OSwapPop
              PA.copyMutablePrimArray stack (sp - 2) stack (sp - 1) 1
              go (sp - 1) (ip + 1) stack
            3 -> interpretBinOp (+) -- OAdd
            4 -> interpretBinOp (-) -- OSub
            5 -> interpretBinOp (*) -- OMul
            6 -> do                 -- ODiv
              b <- PA.readPrimArray stack $ sp - 1
              a <- PA.readPrimArray stack $ sp - 2
              when (b == 0) $ throwInterpretError "Division by zero"
              when (b == (-1) && a == minBound) $
                throwInterpretError "Arithmetic overflow"
              PA.writePrimArray stack (sp - 2) $ a `div` b
              go (sp - 1) (ip + 1) stack
            n -> throwInterpretError $
              "Invalid bytecode: " <> show n <> " at: " <> show ip
      where
        interpretBinOp op = do
          b <- PA.readPrimArray stack $ sp - 1
          a <- PA.readPrimArray stack $ sp - 2
          PA.writePrimArray stack (sp - 2) $ a `op` b
          go (sp - 1) (ip + 1) stack
        {-# INLINE interpretBinOp #-}

        throwIPOOBError ip = throwInterpretError $
          "Instruction index " <> show ip <> " out of bound " <> show (size - 1)

        throwInsufficientElementsError =
          throwInterpretError "Not enough elements to execute operation"

        throwInterpretError = throwError . Error InterpretBytecode

The interpretBytecode' function is where the action happens. It is way more complex than interpretAST, but the complexity has a reason, namely performance.

interpretBytecode' runs inside the ST monad wrapped with the ExceptT monad transformer. ST monad lets us use mutable data structures locally while ensuring the function remains externally pure. ExceptT monad transformer adds support for throwing and propagating errors in a pure manner.

We use PrimArray for our stack, which is a mutable array of unboxed primitive types, in our case an array of Int16 values. Using a mutable unboxed array is much faster than using an immutable and/or boxed one like Seq or Vector due to reduced allocation and/or pointer chasing.

The core of the VM is the go function, a tight, tail-recursive loop that GHC compiles into an efficient machine loop, as we see later. It takes the stack pointer (sp), instruction pointer (ip)⁴, and the stack as arguments.

At the top of each loop, a block of guard clauses checks for stack overflow, underflow, and other error conditions before branching on the current opcode. Placing these checks at the top instead of inside the opcode cases is a deliberate choice. This may make the code slightly harder to understand, but it significantly improves the performance of the loop by moving all branching at the beginning of the loop, resulting in code that is more friendly to the CPU’s Branch Predictor. Also notice how we reduce the number of checks by working with a range of opcodes at once in the opcode >= 2 guard. The checks are also sorted so as to be most performant, guided by profiling and benchmarking⁵.

The handling of each opcode is actually pretty straightforward. We use different PrimArray specific operations to read and write to the stack, while taking care of doing the required bound and arithmetic checks. We also use the readInstr* functions that we wrote earlier.

After carrying out each operation, we reenter the loop by calling it tail-recursively with the right stack and instruction pointers. Finally, we make sure that the execution terminated correctly by checking the state of the stack, and return its first element.

Peeking Under the Hood: GHC Core

We see later that the VM is quite fast, but how does GHC achieve this performance? To see the magic, we can look at GHC’s intermediate language: Core. Core is a simpler functional language than Haskell to which GHC compiles Haskell. The simpler nature of Core makes it easier for GHC to optimize it, and compile it further. We can get the Core code for a program by compiling with the GHC option -ddump-simpl.

The actual Core code for our VM is too verbose to show here, but here is a simplified C-like pseudo-code version of our go loop:

$wgo (stack_addr, ip, sp) {
  if (ip == bytecode_size) {
    return sp;
  }
  if (sp >= stack_size) {
    throw "Stack Overflow";
  }
  if (sp < 0) {
    throw "Stack Underflow";
  }

  opcode = read_byte_at(bytecode_addr, ip);
  // ... other checks ...

  switch (opcode) {
    case 0: // OPush
      val = read_int16_at(bytecode_addr, ip + 1);
      write_int16_at(stack_addr, sp, val);
      jump $wgo(stack_addr, ip + 3, sp + 1);

    case 3: // OAdd
      val2 = read_int16_at(stack_addr, sp - 1);
      val1 = read_int16_at(stack_addr, sp - 2);
      write_int16_at(stack_addr, sp - 2, val1 + val2);
      jump $wgo(stack_addr, ip + 1, sp - 1);

    // ... other cases ...
  }
}

A few key optimizations are worth pointing out:

1. The loop: The tail-recursive go function is compiled into a proper loop. The jump $wgo(...) instruction is effectively a goto, which means there’s no function call overhead for each iteration of the VM loop.

2. Unboxing: The Core code is full of primitive, unboxed types like Int#, Addr#, and Word#, and operations on them. These are raw machine integers and memory addresses, not boxed Haskell objects. This means operations on them are as fast as they would be in C. The stack operations are not function calls on a PrimArray instance, but primitive memory reads and writes on a raw memory address stack_addr.

3. Inlining: The interpretBinOp helper function is completely inlined into the main loop. For OAdd, the code for reading two values, adding them, and writing the result is laid out inline, and works on unboxed values and array address.

In short, GHC has turned our high-level, declarative Haskell code into a low-level loop that looks remarkably like one we would write in C. We get the safety and expressiveness of Haskell, while GHC does the heavy lifting to produce highly optimized code. It’s the best of both worlds!

Testing the VM

We must test the VM to make sure it works correctly⁶. We reuse the success and failure tests for the AST interpreter, as the bytecode interpreter should yield the same result:

bytecodeInterpreterSpec :: Spec
bytecodeInterpreterSpec = describe "Bytecode interpreter" $ do
  forM_ astInterpreterSuccessTests $ \(input, result) ->
    it ("interprets: \"" <> BSC.unpack input <> "\"") $ do
      parseCompileInterpret input `shouldBe` Right result

  forM_ errorTests $ \(input, err) ->
    it ("fails for: \"" <> BSC.unpack input <> "\"") $ do
      parseCompileInterpret input `shouldSatisfy` \case
        Left (Error InterpretBytecode msg) | err == msg -> True
        _ -> False
  where
    parseCompileInterpret = parseSized >=> compile >=> interpretBytecode' 7

    errorTests =
      [ ("1/0", "Division by zero"),
        ("-32768 / -1", "Arithmetic overflow"),
        ( "let a = 0 in let b = 0 in let c = 0 in let d = 0 in let e = 0 in "
            <> "let f = 0 in a + b + c + d + e + f",
          "Stack overflow"
        )
      ]

prop_interpret_ast_returns_same_result_as_compile_assemble_then_interpret_bytecode ::
  Spec
prop_interpret_ast_returns_same_result_as_compile_assemble_then_interpret_bytecode =
  prop ( "Property: Interpret AST returns same result as compile"
          <> " then interpret bytecode" ) $ \expr ->
    interpretAST expr == (compile (sizedExpr expr) >>= interpretBytecode)

We also add a property-based test this time: for any given expression, interpreting the AST should produce the same result as compiling it to bytecode and executing it in the VM⁷.

Our test suite is complete now:

main :: IO ()
main = hspec $ do
  parserSpec
  astInterpreterSpec
  compilerSpec
  prop_print_ast_then_parse_returns_same_ast
  prop_disassemble_bytecode_then_decompile_then_compile_returns_same_bytecode
  bytecodeInterpreterSpec
  prop_interpret_ast_returns_same_result_as_compile_assemble_then_interpret_bytecode

And finally, we run all tests together:

Test run

$ cabal test -O2
Running 1 test suites...
Test suite specs: RUNNING...

Parser
  parses: "1 + 2 - 3 * 4 + 5 / 6 / 0 + 1" [✔]
  parses: "1+2-3*4+5/6/0+1" [✔]
  parses: "1 + -1" [✔]
  parses: "let x = 4 in x + 1" [✔]
  parses: "let x=4in x+1" [✔]
  parses: "let x = 4 in let y = 5 in x + y" [✔]
  parses: "let x = 4 in let y = 5 in x + let z = y in z * z" [✔]
  parses: "let x = 4 in (let y = 5 in x + 1) + let z = 2 in z * z" [✔]
  parses: "let x=4in 2+let y=x-5in x+let z=y+1in z/2" [✔]
  parses: "let x = (let y = 3 in y + y) in x * 3" [✔]
  parses: "let x = let y = 3 in y + y in x * 3" [✔]
  parses: "let x = let y = 1 + let z = 2 in z * z in y + 1 in x * 3" [✔]
  fails for: "" [✔]
  fails for: "1 +" [✔]
  fails for: "1 & 1" [✔]
  fails for: "1 + 1 & 1" [✔]
  fails for: "1 & 1 + 1" [✔]
  fails for: "(" [✔]
  fails for: "(1" [✔]
  fails for: "(1 + " [✔]
  fails for: "(1 + 2" [✔]
  fails for: "(1 + 2}" [✔]
  fails for: "66666" [✔]
  fails for: "-x" [✔]
  fails for: "let 1" [✔]
  fails for: "let x = 1 in " [✔]
  fails for: "let let = 1 in 1" [✔]
  fails for: "let x = 1 in in" [✔]
  fails for: "let x=1 inx" [✔]
  fails for: "letx = 1 in x" [✔]
  fails for: "let x ~ 1 in x" [✔]
  fails for: "let x = 1 & 2 in x" [✔]
  fails for: "let x = 1 inx" [✔]
  fails for: "let x = 1 in x +" [✔]
  fails for: "let x = 1 in x in" [✔]
  fails for: "let x = let x = 1 in x" [✔]
AST interpreter
  interprets: "1" [✔]
  interprets: "1 + 2 - 3 * 4 + 5 / 6 / 1 + 1" [✔]
  interprets: "1 + (2 - 3) * 4 + 5 / 6 / (1 + 1)" [✔]
  interprets: "1 + -1" [✔]
  interprets: "1 * -1" [✔]
  interprets: "let x = 4 in x + 1" [✔]
  interprets: "let x = 4 in let x = x + 1 in x + 2" [✔]
  interprets: "let x = 4 in let y = 5 in x + y" [✔]
  interprets: "let x = 4 in let y = 5 in x + let z = y in z * z" [✔]
  interprets: "let x = 4 in (let y = 5 in x + y) + let z = 2 in z * z" [✔]
  interprets: "let x = let y = 3 in y + y in x * 3" [✔]
  interprets: "let x = let y = 1 + let z = 2 in z * z in y + 1 in x * 3" [✔]
  fails for: "x" [✔]
  fails for: "let x = 4 in y + 1" [✔]
  fails for: "let x = y + 1 in x" [✔]
  fails for: "let x = x + 1 in x" [✔]
  fails for: "1/0" [✔]
  fails for: "-32768 / -1" [✔]
Compiler
  compiles: "1" [✔]
  compiles: "1 + 2 - 3 * 4 + 5 / 6 / 1 + 1" [✔]
  compiles: "1 + (2 - 3) * 4 + 5 / 6 / (1 + 1)" [✔]
  compiles: "let x = 4 in x + 1" [✔]
  compiles: "let x = 4 in let y = 5 in x + y" [✔]
  compiles: "let x = 4 in let x = x + 1 in x + 2" [✔]
  compiles: "let x = let y = 3 in y + y in x * 3" [✔]
  compiles: "let x = let y = 1 + let z = 2 in z * z in y + 1 in x * 3" [✔]
  compiles: "1/0" [✔]
  compiles: "-32768 / -1" [✔]
  fails for: "x" [✔]
  fails for: "let x = 4 in y + 1" [✔]
  fails for: "let x = y + 1 in x" [✔]
  fails for: "let x = x + 1 in x" [✔]
  fails for: "let x = 4 in let y = 1 in let z = 2 in y + x" [✔]
  fails for: "let x = 4 in let y = 5 in x + let z = y in z * z" [✔]
  fails for: "let a = 0 in let b = 0 in let c = 0 in let d = 0 in d" [✔]
  fails for greater sized expr [✔]
  fails for lesser sized expr [✔]
Property: Print AST then parse returns same AST [✔]
  +++ OK, passed 100 tests.
Property: Disassemble bytecode then decompile then compile returns same bytecode [✔]
  +++ OK, passed 100 tests.
Bytecode interpreter
  interprets: "1" [✔]
  interprets: "1 + 2 - 3 * 4 + 5 / 6 / 1 + 1" [✔]
  interprets: "1 + (2 - 3) * 4 + 5 / 6 / (1 + 1)" [✔]
  interprets: "1 + -1" [✔]
  interprets: "1 * -1" [✔]
  interprets: "let x = 4 in x + 1" [✔]
  interprets: "let x = 4 in let x = x + 1 in x + 2" [✔]
  interprets: "let x = 4 in let y = 5 in x + y" [✔]
  interprets: "let x = 4 in let y = 5 in x + let z = y in z * z" [✔]
  interprets: "let x = 4 in (let y = 5 in x + y) + let z = 2 in z * z" [✔]
  interprets: "let x = let y = 3 in y + y in x * 3" [✔]
  interprets: "let x = let y = 1 + let z = 2 in z * z in y + 1 in x * 3" [✔]
  fails for: "1/0" [✔]
  fails for: "-32768 / -1" [✔]
  fails for: "let a = 0 in let b = 0 in let c = 0 in let d = 0 in let e = 0 in let f = 0 in a + b + c + d + e + f" [✔]
Property: Interpret AST returns same result as compile then interpret bytecode [✔]
  +++ OK, passed 100 tests.

Finished in 0.0166 seconds
91 examples, 0 failures
Test suite specs: PASS

Happily, all tests pass.

Benchmarking the VM

Now for the fun part: benchmarking. We use the criterion library to benchmark the code.

{-# LANGUAGE GHC2021 #-}

module Main where

import ArithVMLib
import Control.Arrow ((>>>))
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad ((>=>))
import Criterion
import Criterion.Main
import Criterion.Main.Options
import Criterion.Types
import Data.ByteString qualified as BS

main :: IO ()
main = do
  code <- BS.getContents >>= evaluate . force
  let Right ast = force $ parseSized code
      Right bytecode = force $ compile ast
      Right program = force $ disassemble bytecode
  runMode
    ( Run
        (defaultConfig {reportFile = Just "benchmark.html"})
        Prefix
        []
    )
    [ bgroup
        "pass"
        [ bench "parse" $ whnf (parseSized >>> force) code,
          bench "compile" $ whnf (compile >>> force) ast,
          bench "disassemble" $ whnf (disassemble >>> force) bytecode,
          bench "decompile" $ whnf (decompile >>> force) program
        ],
      bgroup
        "interpret"
        [ bench "ast" $ whnf (fst >>> interpretAST >>> force) ast,
          bench "bytecode" $ whnf (interpretBytecode >>> force) bytecode
        ],
      bgroup
        "run"
        [ bench "ast" $
            whnf (parse >=> interpretAST >>> force) code,
          bench "bytecode" $
            whnf (parseSized >=> compile >=> interpretBytecode >>> force) code
        ]
    ]

We have a benchmark suite to measure the performance of each pass, the two interpreters (AST and bytecode), and the full end-to-end runs⁸. We compile with the following GHC options:

 -O2
 -fllvm
 -funbox-strict-fields
 -funfolding-use-threshold=16
 -threaded
 -rtsopts
 -with-rtsopts=-N2

Benchmark run

$ cat benchmark.tb | cabal bench
Running 1 benchmarks...
Benchmark bench: RUNNING...
benchmarking pass/parse
time                 581.1 ms   (566.7 ms .. 594.3 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 573.5 ms   (570.4 ms .. 577.1 ms)
std dev              3.948 ms   (1.359 ms .. 5.424 ms)
variance introduced by outliers: 19% (moderately inflated)

benchmarking pass/compile
time                 51.00 ms   (50.48 ms .. 52.54 ms)
                     0.998 R²   (0.995 R² .. 1.000 R²)
mean                 50.82 ms   (50.57 ms .. 51.87 ms)
std dev              810.9 μs   (185.8 μs .. 1.509 ms)

benchmarking pass/disassemble
time                 160.3 ms   (154.7 ms .. 166.5 ms)
                     0.998 R²   (0.990 R² .. 1.000 R²)
mean                 155.8 ms   (150.0 ms .. 160.5 ms)
std dev              7.642 ms   (4.255 ms .. 11.76 ms)
variance introduced by outliers: 12% (moderately inflated)

benchmarking pass/decompile
time                 495.1 ms   (454.0 ms .. 523.7 ms)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 506.5 ms   (495.0 ms .. 525.1 ms)
std dev              17.73 ms   (2.167 ms .. 22.59 ms)
variance introduced by outliers: 19% (moderately inflated)

benchmarking interpret/ast
time                 49.57 ms   (49.53 ms .. 49.61 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 49.80 ms   (49.71 ms .. 50.07 ms)
std dev              255.9 μs   (124.2 μs .. 433.9 μs)

benchmarking interpret/bytecode
time                 15.83 ms   (15.79 ms .. 15.88 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 15.79 ms   (15.75 ms .. 15.83 ms)
std dev              96.85 μs   (70.30 μs .. 140.9 μs)

benchmarking run/ast
time                 628.0 ms   (626.7 ms .. 630.5 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 617.2 ms   (610.2 ms .. 621.0 ms)
std dev              6.679 ms   (1.899 ms .. 8.802 ms)
variance introduced by outliers: 19% (moderately inflated)

benchmarking run/bytecode
time                 643.8 ms   (632.5 ms .. 655.3 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 638.3 ms   (635.8 ms .. 641.2 ms)
std dev              2.981 ms   (1.292 ms .. 4.153 ms)
variance introduced by outliers: 19% (moderately inflated)

Benchmark bench: FINISH

Here are the results in a more digestible format:

Benchmark	Mean Time (ms)
pass/parse	573.5
pass/compile	50.8
pass/disassemble	155.8
pass/decompile	506.5
interpret/ast	49.8
interpret/bytecode	15.8
run/ast	617.2
run/bytecode	638.3

Here are the times in a chart (smaller is better):

<noscript></noscript>

Let’s break down these numbers:

• Parsing and decompiling are slow: At ~573ms and ~506ms, these are by far the slowest passes. This isn’t surprising. Parsing with parser combinators has a known trade-off of expressiveness for performance. Decompiling is a shift-reduce parser that reconstructs an AST from a linear stream of opcodes, and we didn’t spend any time optimizing it.
• Compilation is fast: At ~51ms, compilation is an order of magnitude faster than parsing. This is thanks to pre-calculating the bytecode size during the parsing phase, which allows us to pre-allocate a single ByteString and fill it in with low-level pointer operations.
• Bytecode interpretation is blazingly fast: At just ~16ms, our VM’s interpreter is over 3 times faster than the AST interpreter (~50ms), which proves our belief that bytecode interpreters are faster.
• End-to-end runs: Interestingly, the total time to run via bytecode (~638ms) is slightly slower than the run via AST (~617ms). This is because the cost of parsing, compiling, and then interpreting is higher than just parsing and interpreting. The real win for a bytecode VM comes when you compile once and run many times, amortizing the initial compilation cost.

I can already see readers thinking, “Sure that’s fast, but is it faster than C/Rust/Zig/my favourite language?” Let’s find out.

Benchmarking Against C

To get a better sense of our VM’s performance, I rewrote it in C.

The C implementation is a classic manual approach: a hand-written tokenizer and recursive-descent parser, structs with pointers for the AST, and manual memory management and error propagation. The VM is a simple while loop with a switch statement for dispatching opcodes⁹.

To compare our Haskell code against the C code, we need to write the last Haskell module, the CLI app that we demonstrated in the first post:

ArithVMApp.hs

{-# LANGUAGE GHC2021 #-}

module Main where

import ArithVMLib
import Control.Arrow ((>>>))
import Control.Monad ((>=>))
import Data.ByteString qualified as BS
import Data.Foldable (toList)
import Data.Set qualified as Set
import Data.String (IsString (fromString))
import Options.Applicative qualified as O
import System.Exit (exitFailure)
import System.IO qualified as IO
import Test.QuickCheck qualified as Q
import Text.Pretty.Simple qualified as PS

data Command
  = RunPass Pass Input
  | Run Input
  | Generate Int
  deriving (Show, Eq)

data Input = InputFP FilePath | InputStdin deriving (Show, Eq)

instance IsString Input where
  fromString = \case
    "-" -> InputStdin
    fp -> InputFP fp

commandParser :: IO Command
commandParser =
  O.customExecParser (O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty)
    . O.info (O.hsubparser (mconcat subcommandParsers) O.<**> O.helper)
    $ O.fullDesc <> O.header "Bytecode VM for Arithmetic written in Haskell"
  where
    subcommandParsers =
      map
        ( \(command, pass, desc) ->
            O.command command
            . O.info (RunPass pass <$> inputParser)
            $ O.progDesc desc
        )
        [ ("read", Read, "Read an expression from file or STDIN"),
          ("parse", Parse, "Parse expression to AST"),
          ("print", Print, "Parse expression to AST and print it"),
          ("compile", Compile, "Parse and compile expression to bytecode"),
          ("disassemble", Disassemble, "Disassemble bytecode to opcodes"),
          ( "decompile",
            Decompile,
            "Disassemble and decompile bytecode to expression"
          ),
          ("interpret-ast", InterpretAST, "Parse expression and interpret AST"),
          ( "interpret-bytecode",
            InterpretBytecode,
            "Parse, compile and assemble expression, and interpret bytecode"
          )
        ]
        <> [ O.command "run" . O.info (Run <$> inputParser) $
               O.progDesc "Run bytecode",
             O.command "generate" . O.info (Generate <$> maxSizeParser) $
               O.progDesc "Generate a random arithmetic expression"
           ]

    inputParser =
      O.strArgument
        ( O.metavar "FILE"
            <> O.value InputStdin
            <> O.help "Input file, pass - to read from STDIN (default)"
        )

    maxSizeParser =
      O.option
        O.auto
        ( O.long "size"
            <> O.short 's'
            <> O.metavar "INT"
            <> O.value 100
            <> O.help "Maximum size of the generated AST"
        )

main :: IO ()
main = commandParser >>= runCommand

runCommand :: Command -> IO ()
runCommand = \case
  RunPass Read i -> run i (const $ pure ()) (\_ -> Right () :: Either String ())
  RunPass Parse i -> run i (const $ pure ()) parse
  RunPass Print i -> run i pPrintExpr parse
  RunPass Compile i -> run i BS.putStr $ parseSized >=> compile
  RunPass Decompile i -> run i pPrintExpr $ disassemble >=> decompile
  RunPass Disassemble i -> run i (mapM_ print) $ disassemble >>> fmap toList
  RunPass InterpretAST i -> run i print $ parse >=> interpretAST
  RunPass InterpretBytecode i ->
    run i print $ parseSized >=> compile >=> interpretBytecode
  Run i -> run i print interpretBytecode
  Generate maxSize -> Q.generate (exprGen Set.empty maxSize) >>= pPrintExpr
  where
    run input print process = do
      code <- case input of
        InputStdin -> BS.getContents
        InputFP fp -> BS.readFile fp
      case process code of
        Left err -> IO.hPrint IO.stderr err >> exitFailure
        Right val -> print val

    pPrintExpr =
      PS.pPrintOpt PS.CheckColorTty $
        PS.defaultOutputOptionsDarkBg
          { PS.outputOptionsIndentAmount = 2,
            PS.outputOptionsCompact = True
          }

We compile with the following GHC options¹⁰:

 -O2
 -fllvm
 -funbox-strict-fields
 -funfolding-use-threshold=16

And for the C version, we compile using GCC:

gcc -O3 arithvm.c -o arithvm -Wall

Now, let’s see how they stack up against each other. We use hyperfine to run the two executables.

Hyperfine run

$ arith-vm compile benchmark.tb > benchmark.tbc
# Haskell runs
$ hyperfine -L pass read,parse,compile,interpret-bytecode --warmup 10 -r 30 \
    "arith-vm {pass} benchmark.tb"
Benchmark 1: arith-vm read benchmark.tb
  Time (mean ± σ):      30.4 ms ±   0.2 ms    [User: 2.4 ms, System: 15.9 ms]
  Range (min … max):    30.0 ms …  30.9 ms    30 runs

Benchmark 2: arith-vm parse benchmark.tb
  Time (mean ± σ):     567.6 ms ±   5.7 ms    [User: 537.4 ms, System: 22.0 ms]
  Range (min … max):   554.7 ms … 579.9 ms    30 runs

Benchmark 3: arith-vm compile benchmark.tb
  Time (mean ± σ):     630.0 ms ±   4.5 ms    [User: 598.5 ms, System: 23.5 ms]
  Range (min … max):   622.6 ms … 641.1 ms    30 runs

Benchmark 4: arith-vm interpret-bytecode benchmark.tb
  Time (mean ± σ):     650.2 ms ±   4.9 ms    [User: 619.0 ms, System: 23.3 ms]
  Range (min … max):   640.9 ms … 656.6 ms    30 runs

$ hyperfine --warmup 10 -r 30 "arith-vm run benchmark.tbc"
Benchmark 1: arith-vm run benchmark.tbc
  Time (mean ± σ):      29.3 ms ±   0.2 ms    [User: 17.6 ms, System: 2.9 ms]
  Range (min … max):    28.9 ms …  29.6 ms    30 runs

# C runs
$ hyperfine -L pass read,parse,compile,interpret --warmup 10 -r 30 \
    "./arithvm {pass} benchmark.tb"
Benchmark 1: ./arithvm read benchmark.tb
  Time (mean ± σ):      14.2 ms ±   0.2 ms    [User: 0.8 ms, System: 13.0 ms]
  Range (min … max):    14.0 ms …  14.6 ms    30 runs

Benchmark 2: ./arithvm parse benchmark.tb
  Time (mean ± σ):     217.4 ms ±   2.6 ms    [User: 192.2 ms, System: 23.7 ms]
  Range (min … max):   213.6 ms … 223.9 ms    30 runs

Benchmark 3: ./arithvm compile benchmark.tb
  Time (mean ± σ):     254.5 ms ±   2.9 ms    [User: 228.3 ms, System: 24.7 ms]
  Range (min … max):   246.0 ms … 259.1 ms    30 runs

Benchmark 4: ./arithvm interpret benchmark.tb
  Time (mean ± σ):     267.9 ms ±   2.1 ms    [User: 241.5 ms, System: 24.9 ms]
  Range (min … max):   263.4 ms … 272.2 ms    30 runs

$ hyperfine --warmup 10 -r 30 "./arithvm run benchmark.tbc"
Benchmark 1: ./arithvm run benchmark.tbc
  Time (mean ± σ):      13.9 ms ±   0.1 ms    [User: 12.4 ms, System: 1.1 ms]
  Range (min … max):    13.6 ms …  14.1 ms    30 runs

Here’s a summary of the results:

Pass	C Time (ms)	Haskell Time (ms)	Slowdown
Read	14.2	30.4	2.14x
Parse	203.2	537.2	2.64x
Compile	37.1	62.4	1.68x
Interpret	13.4	20.2	1.51x
Run	13.9	29.3	2.11x

I have subtracted the times of previous passes to get the times for individual passes. Here’s the same in a chart (smaller is better):

<noscript></noscript>

As expected, the C implementation is faster across the board, between 1.5x to 2.6x. The biggest difference is in parsing, where the hand-written C parser is more than twice as fast as our combinator-based one. On the other hand, the Haskell VM is only 50% slower than the C VM. In my opinion, the Haskell code’s performance is quite respectable, especially given the safety, expressiveness and conciseness benefits, as illustrated by the code sizes¹¹:

Implementation	Lines of Code
C	775
Haskell	407

The Haskell implementation is almost half the size of the C code. I don’t know about you but I’m perfectly happy with the half as small, half as fast tread-off.

The benchmark results for the VMs become less surprising when I compare the C interpret function with the GHC Core code for interpretBytecode'¹².

int interpret(const uint8_t *bytecode, const long bytecode_size, int16_t *result) {
  VM vm;
  vm_init(&vm);

  while (vm.ip < bytecode_size) {
    if (vm.sp >= STACK_SIZE) { return VM_ERROR_STACK_OVERFLOW; }
    if (vm.sp < 0) { return VM_ERROR_STACK_UNDERFLOW; }

    const uint8_t op = bytecode[vm.ip];
    // other checks

    switch (op) {
    case OP_PUSH: {
      const uint8_t byte1 = bytecode[vm.ip + 1];
      const uint8_t byte2 = bytecode[vm.ip + 2];
      const int16_t value = (int16_t)((uint16_t)byte1 | ((uint16_t)byte2 << 8));

      vm.stack[vm.sp] = value;
      vm.sp++;
      vm.ip += 3;
      break;
    }

    case OP_ADD:
    case OP_SUB:
    case OP_MUL:
    case OP_DIV: {
      int16_t value1 = vm.stack[vm.sp - 2];
      int16_t value2 = vm.stack[vm.sp - 1];

      int16_t result;
      switch (op) {
      case OP_ADD: { result = value1 + value2; break; }
      case OP_SUB: { result = value1 - value2; break; }
      case OP_MUL: { result = value1 * value2; break; }
      case OP_DIV: {
        if (value2 == 0) { return VM_ERROR_DIVISION_BY_ZERO; }
        if (value2 == -1 && value1 == -32768) {
          return VM_ERROR_ARITHMETIC_OVERFLOW;
        }
        result = value1 / value2;
        break;
      }
      }

      vm.stack[vm.sp - 2] = result;
      vm.sp--;
      vm.ip++;
      break;
    }
    // ... other cases ...
    }
  }
  // ... final checks and return ...
}

This structure is almost a 1-to-1 match with the GHC Core code we saw earlier. The C while loop corresponds to the optimized $wgo function that GHC generates, the switch statement is almost identical to the case analysis on the raw opcode byte, and the C stack array is equivalent to the MutableByteArray# GHC uses. GHC effectively compiles our high-level Haskell into a low-level code that is structurally identical to what we wrote by hand in C¹³.

This explains why the performance is in the same ballpark. The remaining performance gap is probably due to the thin layer of abstraction that the Haskell runtime still maintains, but it’s remarkable how close we can get to C-like performance.

Future Directions

While our Haskell program is fast, we can improve certain things:

• Parser optimizations: As the benchmarks showed, parsing is our slowest pass. For better performance, we could replace our Attoparsec-based combinator parser with a parser generator like Alex and Happy, or even write a recursive-descent parser by hand.

• Superinstructions: We could analyze the bytecode for common instruction sequences (like OPush followed by OAdd) and combine them into single superinstructions. This would reduce the instruction dispatch overhead, but may make compilation slower.

• Register-based VM: A register-based VM, which uses a small array of virtual registers instead of a memory-based stack, could significantly reduce memory traffic and improve performance. This would require a more complex compiler capable of register allocation.

• Just-in-Time (JIT) compilation: The ultimate performance boost could come from a JIT compiler. Instead of interpreting bytecode, we could compile it to native machine code at runtime, eliminating the interpreter entirely. Maybe we could use LLVM to build a JIT compiler in Haskell.

Conclusion

And that’s a wrap! We successfully built a bytecode compiler and virtual machine in Haskell. We covered parsing, AST interpretation, compilation, and bytecode execution, as well as, debugging and testing functionalities. Let’s update our checklist:

• Parsing arithmetic expressions to Abstract Syntax Trees (ASTs).
• Unit testing for our parser.
• Interpreting ASTs.
• Compiling ASTs to bytecode.
• Disassembling and decompiling bytecode.
• Unit testing for our compiler.
• Property-based testing for our compiler.
• Efficiently executing bytecode in a virtual machine.
• Unit testing and property-based testing for our VM.
• Benchmarking our code to see how the different passes perform.
• All the while keeping an eye on performance.

The journey from a simple AST interpreter to a bytecode VM has been a rewarding one. We saw a significant performance improvement, learned about how compilers and VMs work, and how to write performant code in Haskell. While our Haskell implementation isn’t as fast as the hand-written C version, it’s far more concise and, I would argue, easier to reason about. It’s a great demonstration of Haskell’s power for writing high-performance—yet safe and elegant—code.

See the full code at:

• ArithVMLib.hs
• ArithVMSpec.hs
• ArithVMBench.hs
• ArithVMApp.hs
• arithvm.c

If you have any questions or comments, please leave a comment below. If you liked this post, please share it. Thanks for reading!

---

1. Actually, QuickCheck does not generate entirely arbitrary inputs. It generates arbitrary inputs with increasing complexity—where the complexity is defined by the user—and asserts the properties on these inputs. When a test fails for a particular input, QuickCheck also tries to simplify the culprit and tries to find the simplest input for which the test fails. This process is called Shrinking in QuickCheck parlance. QuickCheck then shows this simplest input to the user for them to use it to debug their code.↩︎

2. Read this good introduction to QuickCheck if you are unfamiliar.↩︎

3. Notice that we discard the expressions that do not compile successfully.↩︎

4. sp and ip are not actual pointers, but indices into the stack and bytecode arrays respectively.↩︎

5. Guided by the GHC profiler, I tweaked the code in many different ways and ran benchmarks for every change. Then I chose the code that was most performant.↩︎

6. It is extremely important to write good tests before getting your hands dirty with performance optimizations. In my case, the tests saved me many times from breaking the VM while moving code around for performance.↩︎

7. We are using our AST interpreter as a definitional interpreter, assuming it to be correctly implemented because of its simpler nature.↩︎

8. I ran all benchmarks on an Apple M4 Pro 24GB machine against a 142MB file generated using the expression generator we wrote earlier.↩︎

9. I don’t claim to be a great or even a good C programmer. In fact, this C VM is the first substantial C code I have written in decades. I’m sure the code is not most optimized. It may even be ridden with memory management bugs. If you find something wrong, please let me know in the comments.↩︎

10. I tried various RTS options to tweak GHC garbage collection, but the defaults proved to be fastest.↩︎

11. The lines of code are for only the overlapping functionalities between C and Haskell versions.↩︎

12. I did try using Direct Threading and Subroutine Threading in the C code, but they resulted in slower code than the switch-case variant. GCC may be smart enough in case of this simple VM to optimize the switch-case to be faster than threaded code.↩︎

13. You may have noticed that the C interpret function is not laid out in the exact same manner as the Haskell interpretBytecode'.go function. In case of C, moving the checks to the front did not yield in performance improvement. I suspect this may be because GCC is smart enough to do that optimization by itself. The nested switch were also no detriment to the performance of the C code.↩︎

If you liked this post, please leave a comment.

by Abhinav Sarkar (abhinav@abhinavsarkar.net) at October 21, 2025 12:00 AM

Spatial DP: Finding the Largest Square

In the past two weeks we’ve explored a couple different problems in dynamic programming. These were simpler 1-dimensional problems. But dynamic programming is often at its most powerful when you can work across multiple dimensions. In today’s problem, we’ll consider a problem that is actually a 2D spatial problem where we can use dynamic programming.

If you want to learn how to write dynamic programming solutions in Haskell from the ground up, take a look at our Solve.hs course. DP is one of several algorithmic approaches you’ll learn in Module 3!

The Problem

Today’s problem (Maximal Square) is fairly simple conceptually. We are given a grid of 1’s and 0’s like so:

10100
11111
00111
10101

We must return the size of the largest square in the grid composed entirely of 1’s. So in the example above, the answer would be 4. There are two 2x2 squares we can form, starting in the 2nd row, using either the 3rd or 4th column as the “top left” of the square.

We can do a couple small edits to change the answer here. For example, we can flip the second ‘0’ in the bottom row and we’ll get a 3x3 grid, allowing the answer 9:

10100
11111
00111
10111

We could instead flip the second ‘1’ in the third row, and now the answer is only 1, as there are no 2x2 squares remaining:

10100
11111
00101
10101

The Algorithm

To solve this, we can imagine a DP grid that has “layers” where each layer has the same dimensions as the original grid. Each layer has a number “k” associated with it. The index {row,column} at layer k tells us whether or not a square of size k exists in the original grid with size k x k, with the cell {row, column} as its top left cell.

To construct this grid, we would need a base case and a recursive case. The base case is to consider layer 1. This is identical to the original grid we receive. Any location with 1 in the original grid is the top left for a 1x1 square.

So how do we build the layer k+1? This requires one simple insight. Suppose we are dealing with a single index {r,c}. In order for this to be the top left of a square of size k+1, we just need to check that 4 cells begin squares of size k: {r,c}, {r+1,c}, {r,c+1},{r+1,c+1}.

So to form the next layer, we just loop through each index in the layer and fill it in with 1 if it meets that criterion. Once we reach a layer where each entry is 0, we are done. We should return the square of the last layer we found.

There are a few optimizations possible here. Thinking back to our first DP problem, we didn’t need to store the full DP array since each new step only depended on a couple prior values. This time, we don’t need a full grid with “k” layers. We could alternate with only two grids, saving new values from the prior grid, and then making our “new” grid the “old” grid for the next layer.

But even simpler than that, we can keep modifying a single grid in place. Each “new” value we calculate depends on numbers below and/or to its right. So as long as we loop through the grid from left to right and top to bottom, we are safe modifying its values in place. At least, that’s what we’ll do in Rust. In Haskell we could do this with the mutable array API, but we’ll stick with the more conventional, immutable, approach in this article. (You can learn more about Haskell’s mutable arrays in Solve.hs).

Rust Solution

Let’s start with the Rust solution, demonstrating the mutable array approach. We’ll start by defining a series of terms, like the dimensions of our input and our dp grid (which is initially a clone of the input). We’ll also define a boolean (found) to indicate if we’ve found at least a single 1 on the current layer. We’ll track level, the number of layers confirmed to have a 1.

pub fn maximal_square(matrix: Vec<Vec<char>>) -> i32 {
    let m = matrix.len();
    let n = matrix[0].len();
    let mut level = 0;
    let mut dp = matrix.clone();
    let mut found = true;
    ...
    return level * level;
}

Of course, our final answer is just the square of the final “level” we determine. But how do we find this? We’ll need an outer while loop that terminates once we hit a level that does not hold a 1. We reset found as false to start each loop, but at the end of the loop, we’ll increment the level if we have found something.

pub fn maximal_square(matrix: Vec<Vec<char>>) -> i32 {
    let m = matrix.len();
    let n = matrix[0].len();
    let mut level = 0;
    let mut dp = matrix.clone();
    let mut found = true;
    while (found) {
        found = false;
        ...
        if (found) {
            level += 1;
        }
    }
    return level * level;
}

Now the core of the “layer” loop is to loop through each cell, left to right and top to bottom.

pub fn maximal_square(matrix: Vec<Vec<char>>) -> i32 {
    ...
    while (found) {
        found = false;
        for i in 0..m {
            for j in 0..n {
                ...
            }
        }
        if (found) {
            level += 1;
        }
    }
    return level * level;
}

So what happens inside the loop? When we hit a 0 cell, we don’t need to do anything. It always remains a 0 and we haven’t “found” anything. But interesting things happen if we hit a 1.

First, we note that found is now true - this layer is not empty. We have found a k x k square. But second, we should now reset this cell as 0 if it does not make a square of size k+1. We need to first check the dimensions to make sure we don’t go out of bounds, but then also check the 3 spaces, to the right, below, and diagonally away from us. If any of these are 0, we reset this cell as 0.

pub fn maximal_square(matrix: Vec<Vec<char>>) -> i32 {
    ...
    while (found) {
        found = false;
        for i in 0..m {
            for j in 0..n {
                if (dp[i][j] == '1') {
                    found = true;
                    if (i + 1 >= m || 
                        j + 1 >= n || 
                        dp[i][j+1] == '0' ||
                        dp[i+1][j] == '0' ||
                        dp[i+1][j+1] == '0') {
                        dp[i][j] = '0';
                    }
                }
            }
        }
        if (found) {
            level += 1;
        }
    }
    return level * level;
}

And just by filling in this logic, our function is suddenly done! Our inner loop is complete, and our outer loop will break once we find no more increasingly large squares. Here is the full Rust solution:

pub fn maximal_square(matrix: Vec<Vec<char>>) -> i32 {
    let m = matrix.len();
    let n = matrix[0].len();
    let mut level = 0;
    let mut dp = matrix.clone();
    let mut found = true;
    while (found) {
        found = false;
        for i in 0..m {
            for j in 0..n {
                if (dp[i][j] == '1') {
                    found = true;
                    if (i + 1 >= m || 
                        j + 1 >= n || 
                        dp[i][j+1] == '0' ||
                        dp[i+1][j] == '0' ||
                        dp[i+1][j+1] == '0') {
                        dp[i][j] = '0';
                    }
                }
            }
        }
        if (found) {
            level += 1;
        }
    }
    return level * level;
}

Haskell Solution

Now let’s write this in Haskell. We’ll start with a few definitions, including a type alias for our DP map. We’ll take an Array as the problem input, but we want a HashMap for our stateful version since we can “mutate” a HashMap efficiently:

type SquareMap = HM.HashMap (Int, Int) Bool

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = ...
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    ...

Now we’ll define two loop functions - one for the inner loop, one for the outer loop. The “state” for the inner loop is our current level number, as well as the map of the previous layer. The inner loop (coordLoop) should return us an updated map, as well as the found bool value telling us if we’ve found at least a single 1 in the prior layer.

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = ...
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    coordLoop :: (Bool, SquareMap) -> (Int, Int) -> (Bool, SquareMap)
    coordLoop (found, mp) coord@(r, c) = ...

    loop :: Int -> HM.HashMap (Int, Int) Bool -> Int
    loop level mp = ...

    ...

Notice that coordLoop has the argument pattern for foldl, rather than foldr. We want to loop through our coordinates in the proper order, from left to right and top down. If we use a right fold over the indices of the grid, it will go in reverse order.

Let’s start by filling in the inner loop. The first thing to do is determine if the found value needs to change. This is the case if we discover a True value at this index:

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = ...
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    coordLoop :: (Bool, SquareMap) -> (Int, Int) -> (Bool, SquareMap)
    coordLoop (found, mp) coord@(r, c) =
      let found' = found || mp HM.! coord
          ...
      in  (found’, ...)

Now we need the 5 conditions that tell us if this cell should get cleared. Calculate all these, and insert False at the cell if any of them match. Otherwise, keep the map as is!

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = ...
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    coordLoop :: (Bool, SquareMap) -> (Int, Int) -> (Bool, SquareMap)
    coordLoop  (found, mp) coord@(r, c) =
      let found' = found || mp HM.! coord
          tooRight = c >= maxCol
          tooLow = r >= maxRow
          toRight = mp HM.! (r, c + 1)
          under = mp HM.! (r + 1, c)
          diag = mp HM.! (r + 1, c + 1)
          failNext = tooLow || tooRight || not toRight || not under || not diag
          mp' = if failNext then HM.insert coord False mp else mp
      in  (found', mp')

    ...

Now for the outer loop, we use foldl to go through our coordinates using the coordLoop. If we’ve found at least 1 square at this size, then we recurse with the new map and an incremented size. Otherwise we return the square of the current level. Then we just need to call this loop with initial values:

```haskell
type SquareMap = HM.HashMap (Int, Int) Bool

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = loop 0 initialMap
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    coordLoop :: (Bool, SquareMap) -> (Int, Int) -> (Bool, SquareMap)
    coordLoop  (found, mp) coord@(r, c) = ...

    loop :: Int -> HM.HashMap (Int, Int) Bool -> Int
    loop level mp =
      let (found, mp') = foldl coordLoop (False, mp) (A.indices grid)
      in  if found then loop (level + 1) mp' else (level * level)

This completes our Haskell solution!

type SquareMap = HM.HashMap (Int, Int) Bool

maximalSquare :: A.Array (Int, Int) Bool -> Int
maximalSquare grid = loop 0 initialMap
  where
    ((minRow,minCol), (maxRow, maxCol)) = A.bounds grid
    initialMap = HM.fromList [vs | vs <- A.assocs grid]

    coordLoop :: (Bool, SquareMap) -> (Int, Int) -> (Bool, SquareMap)
    coordLoop  (found, mp) coord@(r, c) =
      let found' = found || mp HM.! coord
          tooRight = c >= maxCol
          tooLow = r >= maxRow
          toRight = mp HM.! (r, c + 1)
          under = mp HM.! (r + 1, c)
          diag = mp HM.! (r + 1, c + 1)
          failNext = tooLow || tooRight || not toRight || not under || not diag
          mp' = if failNext then HM.insert coord False mp else mp
      in  (found', mp')

    loop :: Int -> HM.HashMap (Int, Int) Bool -> Int
    loop level mp =
      let (found, mp') = foldl coordLoop (False, mp) (A.indices grid)
      in  if found then loop (level + 1) mp' else (level * level)

Conclusion

Next week we’ll look at one more multi-dimensional DP problem where the dimensions aren’t quite as obvious in this spatial way. The best way to understand DP is to learn related concepts from scratch, including your basic use-it-or-lose-it problems and memoization. You’ll study all these concepts and learn Haskell implementation tricks in Module 3 of Solve.hs. Enroll in the course now!

by James Bowen at October 20, 2025 08:30 AM

71: Stefan Wehr

Stefan Wehr is a professor at the Offenburg University of Applied Sciences. Before becoming a professor, Stefan worked in industry on a large Haskell codebase - specifically one that's not a compiler and not a blockchain. So of course we talked about using Haskell in large projects, software architecture, modularity, type classes and data modeling and the suppression of sums outside of functional programming, and also about teaching Haskell at his current job.

by Haskell Podcast at October 16, 2025 08:00 AM

Exploring Arrows for sequencing effects

Last time, we explored common methods of sequencing effects into little programs. If you haven't read it yet, I'd recommend starting with that, but you can probably manage without it if you insist.

We examined Applicatives, Monads, and Selective Applicatives, and each of these systems had its own trade-offs. We dug into how all approaches exist on the spectrum between being expressive or analyzable and at the end of the post we were unfortunately left wanting something better. Monads reign supreme when it comes to expressiveness as they can express any possible programs we may want to write, but they offer essentially no ability to analyze program they represent without executing it.

On the other hand, Applicatives and Selective Applicatives offered reasonable program analysis, but are unable to express complex programs. They can't even encode programs in which downstream effects materially depend on the results of upstream effects.

These approaches are all based on the same Functor-Applicative-Monad hierarchy, in this post we'll set that aside and rebuild on an altogether different foundation to see if we can do even better.

Setting the goal posts

Before putting in the work let's think critically about the what we felt was missing from the Monad hierarchy and what we wish to gain from a new system.

Here's my wish-list:

• I want to be able to list out every effect that program might perform without executing anything.
• I want to understand the dependencies between the effects including the flow of data between them.
• I want to be able to express programs in which downstream effects can fully utilize the results of upstream effects.

Looking at these requirements, the biggest problem with the Monadic effects system is that it's far too rough-grained in how it handles the results of previous effects. We can see this by reviewing the signature of bind:

(>>=) :: Monad m => m a -> (a -> m b) -> m b

We can see that the result from the previous effect is passed to an arbitrary Haskell function whose job is to return the entire continuation of the program! This permits that function to swap out the entire rest of the program on any particular run, which I'd argue is way more power than the vast majority of reasonable programs require. This is quite frankly a dangerous amount of expressive power, what sort of programs are you writing where you can't even statically identify the possible code paths that might be taken? Even more complex flows like branching, looping and recursion can be expressed in a more structured way without resorting to this sledgehammer level of dynamism.

This tells us we have some room to constrain our programs a bit, and if we're economical about how we do it we can trade that power for the benefits we desire.

We still need to utilize these past results, but we want to avoid opening Pandora's box. That is, we must be careful not to allow the creation of new effects by running arbitrary Haskell functions at execution time. So, in order to use results without a continuation-building function like Monads use, we must meaningfully include the inputs and outputs for our effects in the structure of our effect system itself. We also know that we need to be able to chain these effects together, so we'll need some way to compose them.

If it's not obvious already, this is a great fit for the Category typeclass:

class Category k where
  id :: k a a
  (.) :: k b c -> k a b -> k a c

This already gives us a lot of what we want. Unlike Monads which bake outputs into the continuation of the program using function closures, the Category structure routes inputs and outputs explicitly as part of its structure. Unsurprisingly, it's quite a natural fit; after all, it's called Category Theory, not Monad Theory...

Rebuilding on Categories

Now let's begin to re-implement the examples from the previous post using this new Category-based effect system. In order to save some time, we're actually going to jump up the hierarchy a bit all the way to Arrows.

The Arrow class, if you're not familiar with it, looks like this:

class Category a => Arrow (a :: Type -> Type -> Type) where
  arr :: (b -> c) -> a b c
  (***) :: a b c -> a b' c' -> a (b, b') (c, c')

There are a few other methods we get for free, but this is a minimal set of methods we need to define.

Notice that it has a Category superclass, so we'll use identity and composition from there. We can leverage arr to lift pure Haskell functions into our Category structure. I know we just said we wanted to avoid arbitrary Haskell functions, but note that in this case, just like Applicatives, the function is pure, we can't determine any effects or structure of the effects within the function. No problems here.

We'll re-visit (***) in just a minute.

To get started, how about we re-implement the program we wrote using Applicative in the previous post?

I'll save you from clicking over, here's a refresher on what we did before:

import Control.Applicative (liftA3)
import Control.Monad.Writer (Writer, runWriter, tell)

class (Applicative m) => ReadWrite m where
  readLine :: m String
  writeLine :: String -> m ()

data Command
  = ReadLine
  | WriteLine String
  deriving (Show)

-- | We can implement an instance which runs a dummy interpreter that simply records the commands
-- the program wants to run, without actually executing anything for real.
instance ReadWrite (Writer [Command]) where
  readLine = tell [ReadLine] *> pure "Simulated User Input"
  writeLine msg = tell [WriteLine msg]

-- | A helper to run our program and get the list of commands it would execute
recordCommands :: Writer [Command] String -> [Command]
recordCommands w = snd (runWriter w)

-- | A simple program that greets the user.
myProgram :: (ReadWrite m) => String -> m String
myProgram greeting =
  liftA3
    (\_ name _ -> name)
    (writeLine (greeting <> ", what is your name?"))
    readLine
    (writeLine "Welcome!")

-- We can now run our program in the Writer applicative to see what it would do!
main :: IO ()
main = do
  let commands = recordCommands (myProgram "Hello")
  print commands

-- [WriteLine "Hello, what is your name?", ReadLine, WriteLine "Welcome!"]

The key aspects of this Applicative version were that we could analyze any program which required only an Applicative constraint to get the full list of sequential effects that the program would perform.

Here's the same program, but this time we'll encode the effects using Arrow constraints instead.

But first, a disclaimer: writing Arrow-based programs looks ugly, but don't worry, bear with me for a bit and we'll address that later.

Just like the Applicative version, we'll define a typeclass as the interface to our set of ReadWrite effects, but this time will assume an Arrow constraint:

import Control.Arrow
import Control.Category
import Prelude hiding (id)

class (Arrow k) => ReadWrite k where
  -- Readline has no interesting input, so we use () as input type.
  readLine :: k () String

  -- We track the inputs for the writeLine directly in the Category structure.
  writeLine :: k String ()

-- Helper for embedding a static Haskell value directly into an Arrow
constA :: (Arrow k) => b -> k a b
constA b = arr (\_ -> b)

-- | A simple program which uses a statically provided message to greet the user.
myProgram :: (ReadWrite k) => String -> k () ()
myProgram greeting =
  constA (greeting <> ", what is your name?")
    >>> writeLine
    >>> readLine
    >>> constA "Welcome!"
    >>> writeLine

Great, that should feel pretty straight-forward, it's trivial to convert sequential Applicative programs like this.

In order to run it, we still need to use the IO monad, since that's just how base does IO, but we can use the nifty Kleisli newtype wrapper which turns any monadic computation into a valid Arrow by embedding the monadic effects into the Arrow structure.

Here's how we implement the ReadWrite instance for Kleisli IO:

instance ReadWrite (Kleisli IO) where
  readLine = Kleisli $ \() -> getLine
  writeLine = Kleisli $ \msg -> putStrLn msg

run :: Kleisli IO i o -> i -> IO o
run prog i = do
  runKleisli prog i

And it runs just fine:

>>> run (myProgram "Hello") ()
Hello, what is your name?
Chris
Welcome!

Let's look a little closer at Kleisli:

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

Look familiar? It's just the continuation function from monadic bind hiding in there.

There's a difference though, now that arbitrary function is part of our implementation, not our interface!

This is important, because it means we can invent a different implementation of our ReadWrite interface that just tracks the effects that doesn't have to deal with arbitrary binds like this.

Let's implement a command-recorder that does exactly that.

data Command
  = ReadLine
  | WriteLine
  deriving (Show)

-- Just like the applicative we create a custom implementation of the interface which for static analysis.
-- The parameters are phantom, we won't be running anything, so we only care about
-- the structure of the effects for now.
data CommandRecorder i o = CommandRecorder [Command]

-- We need a Category instance since it's a pre-requisite for Arrow:
instance Category CommandRecorder where
  -- The identity command does nothing, so it records no commands.
  id = CommandRecorder []

  -- Composition of two CommandRecorders just collects their command lists.
  (CommandRecorder cmds2) . (CommandRecorder cmds1) = CommandRecorder (cmds1 <> cmds2)

-- Now the Arrow instance.
instance Arrow CommandRecorder where
  -- We know this function must be pure (barring errors), so we don't
  -- need to track any effects from it.
  arr _ = CommandRecorder []

  -- Don't worry about this combinator yet, we'll come back to it.
  -- For now we'll collect the effects from both sides.
  (CommandRecorder cmds1) *** (CommandRecorder cmds2) = CommandRecorder (cmds1 <> cmds2)

-- | Now implementing the ReadWrite instance is just a matter of collecting the commands
-- the program is running.
instance ReadWrite CommandRecorder where
  readLine = CommandRecorder [ReadLine]
  writeLine = CommandRecorder [WriteLine]

-- | A helper to run our program and get the list of commands it would execute
recordCommands :: CommandRecorder i o -> [Command]
recordCommands (CommandRecorder cmds) = cmds

-- | Here's a helper for printing out the effects a program will run.
analyze :: CommandRecorder i o -> IO ()
analyze prog = do
  let commands = recordCommands prog
  print commands

We can analyze our program and it'll show us which effects it will run if we were to execute it:

>>> analyze (myProgram "Hello")
[WriteLine,ReadLine,WriteLine]

Okay, we've achieved the ability to analyze and execute our program at parity with the Applicative version, but isn't it silly that we're asking the user their name and simply ignoring it? As it turns out, our Arrow interface is quantifiably more expressive: we can use results of past effects in future effects! Since we're now allowing writeLine to take it's input dynamically we no longer track the output in the structure of the command itself. This bit might seem like a step back, but if you still wanted the old version you could of course still define it: writeLineStatic :: String -> k () (). Arrows allow us the flexibility to choose which we prefer. We'll chat a bit more about this later in the article.

Here's something we couldn't do with the Applicative version, we can rewrite the program to greet the user by the name they provide. While we're at it, why not receive the greeting message as an input too?

-- | This program uses the name provided by the user in the response.
myProgram2 :: (ReadWrite k) => k String ()
myProgram2 =
  arr (\greeting -> greeting <> ", what is your name?")
    >>> writeLine
    >>> readLine
    >>> arr (\name -> "Welcome, " <> name <> "!")
    >>> writeLine

Composing arrows lets us route data from one effect to the next, and arr let's us map over values to change them just like fmap does for Functors. The structure of the effects are still statically defined, so even when routing input we can still analyze the entire program ahead of time:

>>> analyze myProgram2
[WriteLine, ReadLine, WriteLine]

>>> run myProgram2 "Hello"
Hello, what is your name?
Chris
Welcome, Chris!

Nifty!

Levelling Up

We're off to a great start, the ability to use the results of past effects is already better than we could get from Selective Applicative, without sacrificing any of the analysis capabilities we had in the Applicative version.

However, at the moment our programs are all still just linear sequences of commands. What happens if we want to route results from an earlier effect down to one far later in the program?

We need a bit more power, time to call back to that (***) we ignored earlier, and while we're at it, let's look at (&&&) too, which we get for free when we implement (***).

(***) :: Arrow k => k a b -> k c d -> k (a, c) (b, d)
(&&&) :: Arrow k => k a b -> k a c -> k a (b, c)

These operators allow us to take two independent programs in our arrow interface and compose them in parallel to one another, rather than sequentially. What parallel means is going to be up to the implementation (within the scope of the Arrow laws), but the key part is that these two sides don't depend on each other, which is distinct from the normal sequential composition we've been doing with (>>>).

With these we can write a now write a slightly more complex program which routes values around, and can forward values from earlier effects to later ones.

import UnliftIO.Directory qualified as Directory

-- The effects we'll need for this example
class (Arrow k) => FileCopy k where
  readLine :: k () String
  writeLine :: k String ()
  copyFile :: k (String, String) ()

data Command
  = ReadLine
  | WriteLine
  | CopyFile
  deriving (Show)

-- Here's the real executable implementation
instance FileCopy (Kleisli IO) where
  readLine = Kleisli $ \() -> getLine
  writeLine = Kleisli $ \msg -> putStrLn msg
  copyFile = Kleisli $ \(src, dest) -> Directory.copyFile src dest

-- Helper prompting the user for input.
prompt :: (FileCopy cat) => String -> cat a String
prompt msg =
  pureC msg
    >>> writeLine
    >>> readLine

fileCopyProgram :: (FileCopy k) => k () ()
fileCopyProgram =
  ( prompt "Select a file to copy"
      &&& prompt "Select the destination"
  )
    >>> copyFile

This program prompts the user for a source file and a destination file, then copies the source file to the destination. Notably, each prompt is independent of one another, that is, they don't have any data-dependencies on one another. But, copyFile takes two arguments, the results of each prompt. (&&&) allows us to express this.

Let's run it:

>>> run fileCopyProgram ()
Select a file to copy
ShoppingList.md
Select the destination
ShoppingList.backup

Uhh, okay so you can't see the result, but trust me it works! Kleisli's implementation of (***) just runs the left side, then the right side; but if, for other applications, you wanted real parallel execution you could write your implementation which runs each pair of parallel operations using Concurrently or something like it and your program will magically become as parallel as your data-dependencies allow! Caveat emptor, but at least having the option is nice, we don't get that from the Monadic interface where data-dependencies are hidden from us.

Now for the analysis.

We could, of course, still collect and print out the list of effects that would be run, but I'm bored of that, so let's level that up too. Now that we have both sequential and parallel composition, our programs are a tree of operations, so our analysis tools should probably follow suite.

Here's a rewrite of our CommandRecorder which tracks the whole tree of effects:

-- | We can represent the effects in our computations as a tree now.
data CommandTree eff
  = Effect eff
  | Identity
  | Composed (CommandTree eff {- >>> -}) (CommandTree eff)
  | -- (***)
    Parallel
      (CommandTree eff) -- First
      (CommandTree eff) -- Second
  deriving (Show, Eq, Ord, Functor, Traversable, Foldable)

data CommandRecorder eff i o = CommandRecorder (CommandTree eff)

instance Category (CommandRecorder eff) where
  -- The identity command does nothing, so it records no commands.
  id = CommandRecorder Identity

  -- I collapse redundant 'Identity's for clarity.
  -- The category laws make this safe to do.
  (CommandRecorder Identity) . (CommandRecorder cmds1) = CommandRecorder cmds1
  (CommandRecorder cmds2) . (CommandRecorder Identity) = CommandRecorder cmds2
  (CommandRecorder cmds2) . (CommandRecorder cmds1) = CommandRecorder (Composed cmds1 cmds2)

instance Arrow (CommandRecorder eff) where
  -- We don't bother tracking pure functions, so arr is a no-op.
  arr _f = CommandRecorder Identity

  -- Track when we fork into parallel execution paths as part of the tree.
  (CommandRecorder cmdsL) *** (CommandRecorder cmdsR) = CommandRecorder (Parallel cmdsL cmdsR)

-- | The interface implementation just tracks the commands
instance FileCopy (CommandRecorder Command) where
  readLine = CommandRecorder (Effect ReadLine)
  writeLine = CommandRecorder (Effect WriteLine)
  copyFile = CommandRecorder (Effect CopyFile)

analyze :: CommandRecorder Command i o -> IO ()
analyze prog = do
  let commands = recordCommands prog
  putStrLn $ renderCommandTree commands

Now we can build the tree of effects, let's take advantage of that and render it as a tree too!

Here's a function that renders any program tree down into a flow-chart description using the mermaid diagramming language.

Don't judge me for the implementation of my mermaid renderer... In fact, if you have a nicer one please send it to me :)

(It's not terribly important, so feel free to skip it)

diagram :: CommandRecorder Command i o -> IO ()
diagram prog = do
  let commands = recordCommands prog
  putStrLn $ commandTreeToMermaid commands

-- | A helper to render our command tree as a flow-chart style mermaid diagram.
commandTreeToMermaid :: forall eff. (Show eff) => CommandTree eff -> String
commandTreeToMermaid cmdTree =
  let preamble = "flowchart TD\n"
      (outputNodes, links) =
        renderNode cmdTree
          & flip runReaderT (["Input"] :: [String])
          & flip evalState (0 :: Int)
   in preamble
        <> unlines
          ( links
              <> ((\output -> output <> " --> Output") <$> outputNodes)
          )
  where
    newNodeId :: (MonadState Int m) => m Int
    newNodeId = do
      n <- get
      put (n + 1)
      return n
    renderNode :: CommandTree eff -> ReaderT [String] (State Int) ([String], [String])
    renderNode = \case
      Effect cmd -> do
        prev <- ask
        nodeId <- newNodeId
        let cmdLabel = show cmd
            nodeDef = show nodeId <> "[" <> cmdLabel <> "]"
            links = do
              x <- prev
              pure $ x <> (" --> " <> nodeDef)
        pure ([nodeDef], links)
      Identity -> do
        nodeId <- newNodeId
        prev <- ask
        let nodeDef = show nodeId <> ("[Identity]")
        let links = do
              x <- prev
              pure $ x <> (" --> " <> nodeDef)
        pure ([nodeDef], links)
      Composed cmds1 cmds2 -> do
        (leftIds, leftNode) <- renderNode cmds1
        (rightIds, rightNode) <- local (const leftIds) $ renderNode cmds2
        pure (rightIds, leftNode <> rightNode)
      Parallel cmds1 cmds2 -> do
        prev <- ask
        nodeId <- newNodeId
        let nodeDef = show nodeId <> ("[Parallel]")
        (leftIds, leftNode) <- local (const [nodeDef]) $ renderNode cmds1
        (rightIds, rightNode) <- local (const [nodeDef]) $ renderNode cmds2
        let thisLink = do
              x <- prev
              pure $ x <> (" --> " <> nodeDef)
            links =
              thisLink
                <> leftNode
                <> rightNode
        pure (leftIds <> rightIds, links)

Here's what the diagram output for our fileCopyProgram looks like:

>>> diagram fileCopyProgram
flowchart TD
Input --> 0[Parallel]
0[Parallel] --> 1[WriteLine]
1[WriteLine] --> 2[ReadLine]
0[Parallel] --> 3[WriteLine]
3[WriteLine] --> 4[ReadLine]
2[ReadLine] --> 5[CopyFile]
4[ReadLine] --> 5[CopyFile]
5[CopyFile] --> Output

And rendered:

Pretty cool eh?

Diagramming is just one thing you can do with our CommandTree, it's just data, you can fold over it to get all the effects, analyze which effects depend on which others, all sorts of things. This provides more clarity into what's happening than Selective's Over and Under newtypes.

This was a very simple example, but I promise you, with combinations of arr, (***) and first/second you can do any possible routing of values that you might like.

What you can't do yet, however, is to branch between possible execution paths, then run only one of them.

Let's add that.

Branching with ArrowChoice

Luckily for us, adding branching is pretty straight-forward. There's an aptly named ArrowChoice in base that we'll go ahead and implement.

ArrowChoice adds a new combinator:

(+++) :: ArrowChoice k => k a b -> k c d -> k (Either a c) (Either b d)

Similar to how (***) lets us represent two parallel and independent programs and fuse them into a single arrow which runs both, (+++) lets us introduce a conditional branch to our program, only one path will be executed based on whether the input value is a Left or a Right.

By implementing (+++) we also get the similar (|||) for free:

(|||) :: ArrowChoice k => k a c -> k b c -> k (Either a b) c

Let's add a Branch case to our CommandTree and implement ArrowChoice for our CommandRecorder.

data CommandTree eff
  = Effect eff
  | Identity
  | Composed (CommandTree eff {- >>> -}) (CommandTree eff)
  | Parallel
      (CommandTree eff) -- First
      (CommandTree eff) -- Second
  | Branch
      (CommandTree eff) -- Left
      (CommandTree eff) -- Right
  deriving (Show, Eq, Ord, Functor, Traversable, Foldable)

instance ArrowChoice (CommandRecorder eff) where
  (CommandRecorder cmds1) +++ (CommandRecorder cmds2) = CommandRecorder (Branch cmds1 cmds2)

No problem. As a reminder, here's the branching program we expressed using Selective Applicatives last time:

-- | A program using Selective effects
myProgram :: (ReadWriteDelete m) => m String
myProgram =
  let msgKind =
        Selective.matchS
          -- The list of values our program has explicit branches for.
          -- These are the values which will be used to crawl codepaths when
          -- analysing your program using `Over`.
          (Selective.cases ["friendly", "mean"])
          -- The action we run to get the input
          readLine
          -- What to do with each input
          ( \case
              "friendly" -> writeLine ("Hello! what is your name?") *> readLine
              "mean" ->
                let msg = unlines [ "Hey doofus, what do you want?"
                                  , "Too late. I deleted your hard-drive."
                                  , "How do you feel about that?"
                                  ]
                 in writeLine msg *> deleteMyHardDrive *> readLine
              -- This can't actually happen.
              _ -> error "impossible"
          )
      prompt = writeLine "Select your mood: friendly or mean"
      fallback =
        (writeLine "That was unexpected. You're an odd one aren't you?")
          <&> \() actualInput -> "Got unknown input: " <> actualInput
   in prompt
        *> Selective.branch
          msgKind
          fallback
          (pure id)

This example was always a bit forced just because of how limited Selective Applicatives are, but let's copy it over into our Arrow setup anyways.

First we'll implement ArrowChoice for our CommandRecorder.

-- Define our effects
class (Arrow k) => ReadWriteDelete k where
  readLine :: k () String

  writeLine :: k String ()

  deleteMyHardDrive :: k () ()

-- New commands for the new effects
data Command
  = ReadLine
  | WriteLine
  | DeleteMyHardDrive
  deriving (Show)

-- Track the effects
instance ReadWriteDelete CommandRecorder where
  readLine = CommandRecorder (Pure ReadLine)
  writeLine = CommandRecorder (Pure WriteLine)
  deleteMyHardDrive = CommandRecorder (Pure DeleteMyHardDrive)

-- Here's the runnable implementation
instance ReadWriteDelete (Kleisli IO) where
  readLine = Kleisli $ \() -> getLine
  writeLine = Kleisli $ \msg -> putStrLn msg
  deleteMyHardDrive = Kleisli $ \() -> putStrLn "Deleting hard drive... Just kidding!"

And here's our program which uses ArrowChoice:

branchingProgram :: (ReadWriteDelete k, ArrowChoice k) => k () ()
branchingProgram =
  pureC "Select your mood: friendly or mean"
    >>> writeLine
    >>> readLine
    >>> mapC
      ( \case
          "mean" -> Left ()
          "friendly" -> Right ()
          -- Just default to friendly
          _ -> Right ()
      )
    >>> let friendly =
              pureC "Hello! what is your name?"
                >>> writeLine
                >>> readLine
                >>> mapC (\name -> "Lovely to meet you, " <> name <> "!")
                >>> writeLine
            mean =
              pureC
                ( unlines
                    [ "Hey doofus, what do you want?",
                      "Too late. I deleted your hard-drive.",
                      "How do you feel about that?"
                    ]
                )
                >>> writeLine
                >>> deleteMyHardDrive
         in mean ||| friendly

Notice again, this version is actually more expressive than the Selective Applicative version, it actually greets the user by the name they provided, how kind.

I'll elide the edits to the mermaid renderer, Branch is very similar to the implementation of Parallel.

Let's make a mermaid chart like before:

>>> diagram branchingProgram
flowchart TD
Input --> 0[WriteLine]
0[WriteLine] --> 1[ReadLine]
1[ReadLine] --> 2[Branch]
2[Branch] --> 3[WriteLine]
3[WriteLine] --> 4[DeleteMyHardDrive]
2[Branch] --> 5[WriteLine]
5[WriteLine] --> 6[ReadLine]
6[ReadLine] --> 7[WriteLine]
4[DeleteMyHardDrive] --> Output
7[WriteLine] --> Output

See how it's now clear that the effects on one branch differ from another?

And of course we can run it just as you'd expect:

>>> run branchingProgram
Select your mood: friendly or mean
friendly
Hello! what is your name?
Joe
Lovely to meet you, Joe!

>>> run branchingProgram
Select your mood: friendly or mean
mean
Hey doofus, what do you want?
Too late. I deleted your hard-drive.
How do you feel about that?

Deleting hard drive... Just kidding!

Okay, so the syntax of that last example was starting to get pretty hairy, if only there was something like do-notation, but for arrows...

Arrow Notation

By enabling the {-# LANGUAGE Arrows #-} pragma we can use a form of do-notation with arrows. It will automatically route your inputs wherever you need them using combinators from the Arrow class and will even translate if and case statements into ArrowChoice combinators, it's very impressive.

I won't explain Arrow Notation deeply here, so go ahead and check out the GHC Manual for a more detailed look.

Here's what our branching program looks like when we translate it:

branchingProgramArrowNotation :: (ReadWriteDelete k, ArrowChoice k) => k () ()
branchingProgramArrowNotation = proc () -> do
  writeLine -< "Select your mood: friendly or mean"
  mood <- readLine -< ()
  case mood of
    "mean" -> mean -< ()
    "friendly" -> friendly -< ()
    _ -> friendly -< ()
  where
    friendly = proc () -> do
      writeLine -< "Hello! what is your name?"
      name <- readLine -< ()
      writeLine -< "Lovely to meet you, " <> name <> "!"

    mean = proc () -> do
      writeLine
        -<
          unlines
            [ "Hey doofus, what do you want?",
              "Too late. I deleted your hard-drive.",
              "How do you feel about that?"
            ]
      deleteMyHardDrive -< ()

It takes a bit of getting used to, but it's not so bad.

Here's the diagram, so we can get an idea of how it's being translated:

It's not quite as pretty, the translation introduces a lot of unnecessary calls to Parallel where it's just inserting Identity on the other side, this is perfectly valid, since the Category laws require that the Identity won't affect behaviour, but in our case it's messy and is clogging up our diagram, so let's clean it up.

The command tree we build as an intermediate step is just a value, so we can transform it to clean it up no problem.

If you derive Data and Plated for our Command and CommandTree types then we can do this with a simple transform on the tree. transform will rebuild the tree from the bottom up removing any redundant Identity nodes as it goes.

unredundify :: (Data eff) => CommandTree eff -> CommandTree eff
unredundify = transform \case
  Parallel Identity right -> right
  Parallel left Identity -> left
  Composed Identity right -> right
  Composed left Identity -> left
  other -> other

Diagramming the unredundified version looks much cleaner:

We can see here that the with multiple arms are getting collapsed into a sequence of binary branches, which is perfectly correct of course, but if you wanted to diagram it as a single branch you could rewrite the Branch constructor to have a list of options and collapse them all down with another rewrite rule. Same for Parallels of course. You can really do whatever is most useful for your use-case.

Arrow notation has its quirks, but it's still a substantial improvement over doing argument routing completely manually.

Static vs Dynamic data

It's worth a quick note on the difference between static and dynamic data with Arrows. With Applicatives, all the data needed to define an effect's behaviour was static, that is, it must be known at the time the program was constructed, though this might still be at runtime for the greater Haskell program.

With Arrows it's possible to interleave static and dynamic data, it's up to the author of the interface.

For example, if one were constructing a build-system they might have an interface like this:

class (Arrow k) => Builder k where
  dynamicReadFile :: k FilePath String
  staticReadFile :: FilePath -> k () String

dynamicReadFile takes its FilePath as a dynamic input, so we won't know which file we're going to read until execution time, however staticReadFile takes its FilePath as a static input. You pass it a single FilePath as a Haskell value when you construct the program. In this case we can embed the FilePath into the structure of the effect itself so that it's available during analysis.

While this is a bit more of an advanced use-case, it can be very useful. In the build-system case you could provide any statically known dependency files using staticReadFile and the build-system could check if those files have changed since the last run and safely replace some subtrees of the build with cached results if no dependencies in that subtree have changed.

This sort of thing takes careful thought and design, but provides a lot of flexibility which can unlock whole new programming techniques.

Folks may well have heard of Haxl, it's a Haskell library for analyzing programs and batching and caching requests to remote data sources. The implementation and interface for Haxl is moderately complex, and is limited in what it can do by the fact that it uses Monads. I'm curious how effective an Arrow-based version could be.

What's next?

We explored enough classes to enable most basic programs here. At this point you can branch, express independence between computations, and route input anywhere you need it. In case you're still hankering for a bit more expressive power we'll do a lightning quick tour of a few more classes.

There's ArrowLoop which encodes fixed-point style recursion.

class Arrow a => ArrowLoop a where
  loop :: a (b, d) (c, d) -> a b c

Interestingly, this is actually just another name for Costrong, as you can see by comparing with Costrong from the profunctors package.

If you really really need to be able to completely restructure your program on the fly you can do so using the ArrowApply class, which enables applying arbitrary runtime-created arrows.

class Arrow a => ArrowApply a where
    app :: a (a b c, b) c

This gives you the wildly expressive power to define entirely new code-paths at runtime. I'd still argue that reasonable programs that actually need to do this are pretty rare, but sometimes it's a useful shortcut to avoid some tedium. Note that if you use app, any effects within the dynamically applied arrow will be hidden from analysis, but you can still analyze the non-dynamic parts.

There are a few additional interesting classes which are strangely missing from base; but they have counterparts in profunctors. One example would be an arrow counterpart to Cochoice, which, if it existed, would look something like this:

class (Arrow k) => ArrowCochoice k where
  unright :: k (Either d a) (Either d b) -> k a b
  unleft :: k (Either a d) (Either b d) -> k a b

While the behaviour ultimately depends on the implementation, you can use this to implement things like recursive loops and while-loops, which avoids one of the more common needs for ArrowApply while preserving analysis over the contents of the loop.

There's some other good stuff in profunctors so I'd recommend just browsing around over there, (Thanks Ed). Traversing lets you apply a profunctor to elements of a Traversable container, Mapping does the same for Functors.

Anyways, you can see that most behaviours you take for granted when writing Haskell code with arbitrary functions in do-notation binds can generally be decomposed into some combination of Arrow typeclasses which accomplish the same thing. Using the principal of least-power is a good rule of thumb here. Generally you should use the lowest-power abstraction you can reasonably encode your program with, that will ensure you'll have the strongest potential for analysis.

In Summary

We've discovered that by switching from the Functor-Applicative-Monad effect system to a Category and Arrow hierarchy we can express significantly more complex and expressive programs while maintaining the ability to deeply introspect the programs we create.

We learned how we can collect additional typeclasses to gain more expressive power, and how we can implement custom instances to analyze and even diagram our programs.

Lastly we took a look at Arrow notation and how it improves the burden of syntax for writing these sorts of programs.

So, should we all abandon Monads and write everything using Arrows instead? Truthfully, I do believe they comprise a better foundation; so while the current Haskell ecosystem is all-in on Monads, if you the reader happen to be designing the effects system for a brand new functional programming language, why not give Arrows a try?

Hopefully you learned something 🤞! Did you know I'm currently writing a book? It's all about Lenses and Optics! It takes you all the way from beginner to optics-wizard and it's currently in early access! Consider supporting it, and more posts like this one by pledging on my Patreon page! It takes quite a bit of work to put these things together, if I managed to teach your something or even just entertain you for a minute or two maybe send a few bucks my way for a coffee? Cheers! �

October 16, 2025 12:00 AM

Arrows to Arrows, Categories to Queries

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

SELECT
f0 AS f0
FROM
(SELECT
 f0 AS f0, f1 AS f1
 FROM
 (SELECT *
  FROM
  (WITH t0 AS
   (SELECT *
    FROM
    (WITH RECURSIVE recursion AS
     (SELECT
      clock_timestamp() as step
      , *
      FROM
      (WITH t1 AS
       (SELECT *
        FROM
        (SELECT
         f0 AS f0, f1 AS f1, NULL::integer AS f2, NULL::integer AS f3
         FROM
         (WITH t2 AS
          (SELECT * FROM (SELECT 0 as f0) AS _)
          SELECT *
          FROM
          (SELECT * FROM (SELECT f0 AS f0 FROM t2 AS _) AS _
           CROSS JOIN
           (SELECT f0 AS f1 FROM t2 AS _))
          AS _)
         AS _)
        AS _)
       SELECT *
       FROM
       (WITH t3 AS
        (SELECT *
         FROM
         (-- undist
          SELECT *
          FROM
          (SELECT
           f0 AS f0, NULL::integer AS f1, f1 AS f2
           FROM
           (-- undist1
            SELECT * FROM t1 AS _ WHERE "f0" IS NOT NULL)
           AS _)
          AS _
          UNION
          SELECT *
          FROM
          (SELECT
           NULL::integer AS f0, f2 AS f1, f3 AS f2
           FROM
           (-- dist2
            SELECT * FROM t1 AS _ WHERE "f2" IS NOT NULL)
           AS _)
          AS _)
         AS _)
        SELECT *
        FROM
        (WITH t4 AS
         (SELECT *
          FROM
          (SELECT *
           FROM
           (SELECT
            f0 AS f0, f1 AS f1
            FROM
            (WITH t5 AS
             (SELECT * FROM t3 AS _)
             SELECT *
             FROM
             (WITH t6 AS
              (SELECT *
               FROM
               (SELECT *
                FROM
                (SELECT
                 f0 AS f0
                 FROM
                 (WITH t7 AS
                  (SELECT * FROM (SELECT f0 AS f0, f1 AS f1 FROM t5 AS _) AS _)
                  SELECT *
                  FROM
                  (SELECT *
                   FROM
                   (SELECT
                    f0 AS f0
                    FROM
                    (-- join1
                     SELECT * FROM t7 AS _ WHERE "f0" IS NOT NULL)
                    AS _)
                   AS _
                   UNION
                   SELECT *
                   FROM
                   (SELECT
                    f1 AS f0
                    FROM
                    (-- join2
                     SELECT * FROM t7 AS _ WHERE "f1" IS NOT NULL)
                    AS _)
                   AS _)
                  AS _)
                 AS _)
                AS _
                CROSS JOIN
                (SELECT f0 AS f1, f1 AS f2, f2 AS f3 FROM t5 AS _))
               AS _)
              SELECT *
              FROM
              (WITH t8 AS
               (SELECT *
                FROM
                (SELECT *
                 FROM
                 (SELECT
                  f0 AS f0, f1 AS f1
                  FROM
                  (WITH t9 AS
                   (SELECT *
                    FROM
                    (SELECT
                     f0 - f1 AS f0
                     FROM
                     (WITH t10 AS
                      (SELECT * FROM t6 AS _)
                      SELECT *
                      FROM
                      (SELECT *
                       FROM
                       (SELECT f0 AS f0 FROM (SELECT f0 AS f0 FROM t10 AS _) AS _)
                       AS _
                       CROSS JOIN
                       (SELECT f0 AS f1 FROM (SELECT 100 as f0 FROM t10 AS _) AS _))
                      AS _)
                     AS _)
                    AS _)
                   SELECT *
                   FROM
                   (SELECT *
                    FROM
                    (SELECT
                     abs(f0) as f0, NULL::integer as f1
                     FROM
                     t9
                     AS _
                     WHERE
                     f0 < 0)
                    AS _
                    UNION
                    SELECT *
                    FROM
                    (SELECT NULL::integer as f0, f0 as f1 FROM t9 AS _ WHERE f0 >= 0)
                    AS _)
                   AS _)
                  AS _)
                 AS _
                 CROSS JOIN
                 (SELECT f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5 FROM t6 AS _))
                AS _)
               SELECT *
               FROM
               (WITH t11 AS
                (SELECT *
                 FROM
                 (SELECT *
                  FROM
                  (SELECT
                   f0 AS f0, f1 AS f1
                   FROM
                   (SELECT f0 AS f0, f1 AS f1 FROM t8 AS _)
                   AS _)
                  AS _
                  CROSS JOIN
                  (SELECT
                   f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5, f4 AS f6, f5 AS f7
                   FROM
                   t8
                   AS _))
                 AS _)
                SELECT *
                FROM
                (WITH t12 AS
                 (SELECT *
                  FROM
                  (-- dist
                   SELECT *
                   FROM
                   (SELECT
                    f0 AS f0, f2 AS f1, NULL::integer AS f10, NULL::integer AS f11, NULL::integer AS f12, NULL::integer AS f13, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5, f7 AS f6, NULL::integer AS f7, NULL::integer AS f8, NULL::integer AS f9
                    FROM
                    (-- dist1
                     SELECT * FROM t11 AS _ WHERE "f0" IS NOT NULL)
                    AS _)
                   AS _
                   UNION
                   SELECT *
                   FROM
                   (SELECT
                    NULL::integer AS f0, NULL::integer AS f1, f4 AS f10, f5 AS f11, f6 AS f12, f7 AS f13, NULL::integer AS f2, NULL::integer AS f3, NULL::integer AS f4, NULL::integer AS f5, NULL::integer AS f6, f1 AS f7, f2 AS f8, f3 AS f9
                    FROM
                    (-- dist2
                     SELECT * FROM t11 AS _ WHERE "f1" IS NOT NULL)
                    AS _)
                   AS _)
                  AS _)
                 SELECT *
                 FROM
                 (SELECT *
                  FROM
                  (SELECT
                   NULL::integer AS f0, f0 AS f1
                   FROM
                   (SELECT
                    f0 + f1 AS f0
                    FROM
                    (WITH t13 AS
                     (SELECT *
                      FROM
                      (SELECT
                       f0 AS f0, f1 AS f1, f2 AS f2, f3 AS f3, f4 AS f4, f5 AS f5, f6 AS f6
                       FROM
                       (-- join1
                        SELECT * FROM t12 AS _
                        WHERE
                        ("f0" IS NOT NULL) AND ((("f1" IS NOT NULL) OR ("f2" IS NOT NULL)) AND (("f3" IS NOT NULL) AND ((("f4" IS NOT NULL) OR ("f5" IS NOT NULL)) AND ("f6" IS NOT NULL)))))
                       AS _)
                      AS _)
                     SELECT *
                     FROM
                     (SELECT *
                      FROM
                      (SELECT
                       f0 AS f0
                       FROM
                       (SELECT
                        f0 AS f0
                        FROM
                        (SELECT
                         f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                         FROM
                         (SELECT
                          f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                          FROM
                          t13
                          AS _)
                         AS _)
                        AS _)
                       AS _)
                      AS _
                      CROSS JOIN
                      (SELECT f0 AS f1 FROM (SELECT 1 as f0 FROM t13 AS _) AS _))
                     AS _)
                    AS _)
                   AS _)
                  AS _
                  UNION
                  SELECT *
                  FROM
                  (SELECT
                   f0 AS f0, NULL::integer AS f1
                   FROM
                   (SELECT
                    f0 AS f0
                    FROM
                    (SELECT
                     f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                     FROM
                     (SELECT
                      f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                      FROM
                      (SELECT
                       f7 AS f0, f8 AS f1, f9 AS f2, f10 AS f3, f11 AS f4, f12 AS f5, f13 AS f6
                       FROM
                       (-- join2
                        SELECT * FROM t12 AS _
                        WHERE
                        ("f7" IS NOT NULL) AND ((("f8" IS NOT NULL) OR ("f9" IS NOT NULL)) AND (("f10" IS NOT NULL) AND ((("f11" IS NOT NULL) OR ("f12" IS NOT NULL)) AND ("f13" IS NOT NULL)))))
                       AS _)
                      AS _)
                     AS _)
                    AS _)
                   AS _)
                  AS _)
                 AS _)
                AS _)
               AS _)
              AS _)
             AS _)
            AS _)
           AS _
           CROSS JOIN
           (SELECT f0 AS f2 FROM (SELECT f2 AS f0 FROM t3 AS _) AS _))
          AS _)
         SELECT *
         FROM
         (-- dist
          SELECT *
          FROM
          (SELECT
           f0 AS f0, f2 AS f1, NULL::integer AS f2, NULL::integer AS f3
           FROM
           (-- dist1
            SELECT * FROM t4 AS _ WHERE "f0" IS NOT NULL)
           AS _)
          AS _
          UNION
          SELECT *
          FROM
          (SELECT
           NULL::integer AS f0, NULL::integer AS f1, f1 AS f2, f2 AS f3
           FROM
           (-- dist2
            SELECT * FROM t4 AS _ WHERE "f1" IS NOT NULL)
           AS _)
          AS _)
         AS _)
        AS _)
       AS _)
      AS _
      UNION ALL
      SELECT
      clock_timestamp() as step
      , *
      FROM
      (SELECT *
       FROM
       (WITH t14 AS
        (SELECT * FROM recursion AS _)
        SELECT *
        FROM
        (WITH t15 AS
         (SELECT *
          FROM
          (-- undist
           SELECT *
           FROM
           (SELECT
            f0 AS f0, NULL::integer AS f1, f1 AS f2
            FROM
            (-- undist1
             SELECT * FROM t14 AS _ WHERE "f0" IS NOT NULL)
            AS _)
           AS _
           UNION
           SELECT *
           FROM
           (SELECT
            NULL::integer AS f0, f2 AS f1, f3 AS f2
            FROM
            (-- dist2
             SELECT * FROM t14 AS _ WHERE "f2" IS NOT NULL)
            AS _)
           AS _)
          AS _)
         SELECT *
         FROM
         (WITH t16 AS
          (SELECT *
           FROM
           (SELECT *
            FROM
            (SELECT
             f0 AS f0, f1 AS f1
             FROM
             (WITH t17 AS
              (SELECT * FROM t15 AS _)
              SELECT *
              FROM
              (WITH t18 AS
               (SELECT *
                FROM
                (SELECT *
                 FROM
                 (SELECT
                  f0 AS f0
                  FROM
                  (WITH t19 AS
                   (SELECT * FROM (SELECT f0 AS f0, f1 AS f1 FROM t17 AS _) AS _)
                   SELECT *
                   FROM
                   (SELECT *
                    FROM
                    (SELECT
                     f0 AS f0
                     FROM
                     (-- join1
                      SELECT * FROM t19 AS _ WHERE "f0" IS NOT NULL)
                     AS _)
                    AS _
                    UNION
                    SELECT *
                    FROM
                    (SELECT
                     f1 AS f0
                     FROM
                     (-- join2
                      SELECT * FROM t19 AS _ WHERE "f1" IS NOT NULL)
                     AS _)
                    AS _)
                   AS _)
                  AS _)
                 AS _
                 CROSS JOIN
                 (SELECT f0 AS f1, f1 AS f2, f2 AS f3 FROM t17 AS _))
                AS _)
               SELECT *
               FROM
               (WITH t20 AS
                (SELECT *
                 FROM
                 (SELECT *
                  FROM
                  (SELECT
                   f0 AS f0, f1 AS f1
                   FROM
                   (WITH t21 AS
                    (SELECT *
                     FROM
                     (SELECT
                      f0 - f1 AS f0
                      FROM
                      (WITH t22 AS
                       (SELECT * FROM t18 AS _)
                       SELECT *
                       FROM
                       (SELECT *
                        FROM
                        (SELECT f0 AS f0 FROM (SELECT f0 AS f0 FROM t22 AS _) AS _)
                        AS _
                        CROSS JOIN
                        (SELECT f0 AS f1 FROM (SELECT 100 as f0 FROM t22 AS _) AS _))
                       AS _)
                      AS _)
                     AS _)
                    SELECT *
                    FROM
                    (SELECT *
                     FROM
                     (SELECT
                      abs(f0) as f0, NULL::integer as f1
                      FROM
                      t21
                      AS _
                      WHERE
                      f0 < 0)
                     AS _
                     UNION
                     SELECT *
                     FROM
                     (SELECT NULL::integer as f0, f0 as f1 FROM t21 AS _ WHERE f0 >= 0)
                     AS _)
                    AS _)
                   AS _)
                  AS _
                  CROSS JOIN
                  (SELECT f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5 FROM t18 AS _))
                 AS _)
                SELECT *
                FROM
                (WITH t23 AS
                 (SELECT *
                  FROM
                  (SELECT *
                   FROM
                   (SELECT
                    f0 AS f0, f1 AS f1
                    FROM
                    (SELECT f0 AS f0, f1 AS f1 FROM t20 AS _)
                    AS _)
                   AS _
                   CROSS JOIN
                   (SELECT
                    f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5, f4 AS f6, f5 AS f7
                    FROM
                    t20
                    AS _))
                  AS _)
                 SELECT *
                 FROM
                 (WITH t24 AS
                  (SELECT *
                   FROM
                   (-- dist
                    SELECT *
                    FROM
                    (SELECT
                     f0 AS f0, f2 AS f1, NULL::integer AS f10, NULL::integer AS f11, NULL::integer AS f12, NULL::integer AS f13, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5, f7 AS f6, NULL::integer AS f7, NULL::integer AS f8, NULL::integer AS f9
                     FROM
                     (-- dist1
                      SELECT * FROM t23 AS _ WHERE "f0" IS NOT NULL)
                     AS _)
                    AS _
                    UNION
                    SELECT *
                    FROM
                    (SELECT
                     NULL::integer AS f0, NULL::integer AS f1, f4 AS f10, f5 AS f11, f6 AS f12, f7 AS f13, NULL::integer AS f2, NULL::integer AS f3, NULL::integer AS f4, NULL::integer AS f5, NULL::integer AS f6, f1 AS f7, f2 AS f8, f3 AS f9
                     FROM
                     (-- dist2
                      SELECT * FROM t23 AS _ WHERE "f1" IS NOT NULL)
                     AS _)
                    AS _)
                   AS _)
                  SELECT *
                  FROM
                  (SELECT *
                   FROM
                   (SELECT
                    NULL::integer AS f0, f0 AS f1
                    FROM
                    (SELECT
                     f0 + f1 AS f0
                     FROM
                     (WITH t25 AS
                      (SELECT *
                       FROM
                       (SELECT
                        f0 AS f0, f1 AS f1, f2 AS f2, f3 AS f3, f4 AS f4, f5 AS f5, f6 AS f6
                        FROM
                        (-- join1
                         SELECT * FROM t24 AS _
                         WHERE
                         ("f0" IS NOT NULL) AND ((("f1" IS NOT NULL) OR ("f2" IS NOT NULL)) AND (("f3" IS NOT NULL) AND ((("f4" IS NOT NULL) OR ("f5" IS NOT NULL)) AND ("f6" IS NOT NULL)))))
                        AS _)
                       AS _)
                      SELECT *
                      FROM
                      (SELECT *
                       FROM
                       (SELECT
                        f0 AS f0
                        FROM
                        (SELECT
                         f0 AS f0
                         FROM
                         (SELECT
                          f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                          FROM
                          (SELECT
                           f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                           FROM
                           t25
                           AS _)
                          AS _)
                         AS _)
                        AS _)
                       AS _
                       CROSS JOIN
                       (SELECT f0 AS f1 FROM (SELECT 1 as f0 FROM t25 AS _) AS _))
                      AS _)
                     AS _)
                    AS _)
                   AS _
                   UNION
                   SELECT *
                   FROM
                   (SELECT
                    f0 AS f0, NULL::integer AS f1
                    FROM
                    (SELECT
                     f0 AS f0
                     FROM
                     (SELECT
                      f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                      FROM
                      (SELECT
                       f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                       FROM
                       (SELECT
                        f7 AS f0, f8 AS f1, f9 AS f2, f10 AS f3, f11 AS f4, f12 AS f5, f13 AS f6
                        FROM
                        (-- join2
                         SELECT * FROM t24 AS _
                         WHERE
                         ("f7" IS NOT NULL) AND ((("f8" IS NOT NULL) OR ("f9" IS NOT NULL)) AND (("f10" IS NOT NULL) AND ((("f11" IS NOT NULL) OR ("f12" IS NOT NULL)) AND ("f13" IS NOT NULL)))))
                        AS _)
                       AS _)
                      AS _)
                     AS _)
                    AS _)
                   AS _)
                  AS _)
                 AS _)
                AS _)
               AS _)
              AS _)
             AS _)
            AS _
            CROSS JOIN
            (SELECT f0 AS f2 FROM (SELECT f2 AS f0 FROM t15 AS _) AS _))
           AS _)
          SELECT *
          FROM
          (-- dist
           SELECT *
           FROM
           (SELECT
            f0 AS f0, f2 AS f1, NULL::integer AS f2, NULL::integer AS f3
            FROM
            (-- dist1
             SELECT * FROM t16 AS _ WHERE "f0" IS NOT NULL)
            AS _)
           AS _
           UNION
           SELECT *
           FROM
           (SELECT
            NULL::integer AS f0, NULL::integer AS f1, f1 AS f2, f2 AS f3
            FROM
            (-- dist2
             SELECT * FROM t16 AS _ WHERE "f1" IS NOT NULL)
            AS _)
           AS _)
          AS _)
         AS _)
        AS _)
       AS _
       WHERE
       ("f2" IS NOT NULL) AND ("f3" IS NOT NULL))
      AS _)
     SELECT * FROM recursion ORDER BY step DESC LIMIT 1)
    AS _)
   SELECT *
   FROM
   (WITH t26 AS
    (SELECT *
     FROM
     (-- undist
      SELECT *
      FROM
      (SELECT
       f0 AS f0, NULL::integer AS f1, f1 AS f2
       FROM
       (-- undist1
        SELECT * FROM t0 AS _ WHERE "f0" IS NOT NULL)
       AS _)
      AS _
      UNION
      SELECT *
      FROM
      (SELECT
       NULL::integer AS f0, f2 AS f1, f3 AS f2
       FROM
       (-- dist2
        SELECT * FROM t0 AS _ WHERE "f2" IS NOT NULL)
       AS _)
      AS _)
     AS _)
    SELECT *
    FROM
    (WITH t27 AS
     (SELECT *
      FROM
      (SELECT *
       FROM
       (SELECT
        f0 AS f0, f1 AS f1
        FROM
        (WITH t28 AS
         (SELECT * FROM t26 AS _)
         SELECT *
         FROM
         (WITH t29 AS
          (SELECT *
           FROM
           (SELECT *
            FROM
            (SELECT
             f0 AS f0
             FROM
             (WITH t30 AS
              (SELECT * FROM (SELECT f0 AS f0, f1 AS f1 FROM t28 AS _) AS _)
              SELECT *
              FROM
              (SELECT *
               FROM
               (SELECT
                f0 AS f0
                FROM
                (-- join1
                 SELECT * FROM t30 AS _ WHERE "f0" IS NOT NULL)
                AS _)
               AS _
               UNION
               SELECT *
               FROM
               (SELECT
                f1 AS f0
                FROM
                (-- join2
                 SELECT * FROM t30 AS _ WHERE "f1" IS NOT NULL)
                AS _)
               AS _)
              AS _)
             AS _)
            AS _
            CROSS JOIN
            (SELECT f0 AS f1, f1 AS f2, f2 AS f3 FROM t28 AS _))
           AS _)
          SELECT *
          FROM
          (WITH t31 AS
           (SELECT *
            FROM
            (SELECT *
             FROM
             (SELECT
              f0 AS f0, f1 AS f1
              FROM
              (WITH t32 AS
               (SELECT *
                FROM
                (SELECT
                 f0 - f1 AS f0
                 FROM
                 (WITH t33 AS
                  (SELECT * FROM t29 AS _)
                  SELECT *
                  FROM
                  (SELECT *
                   FROM
                   (SELECT f0 AS f0 FROM (SELECT f0 AS f0 FROM t33 AS _) AS _)
                   AS _
                   CROSS JOIN
                   (SELECT f0 AS f1 FROM (SELECT 100 as f0 FROM t33 AS _) AS _))
                  AS _)
                 AS _)
                AS _)
               SELECT *
               FROM
               (SELECT *
                FROM
                (SELECT
                 abs(f0) as f0, NULL::integer as f1
                 FROM
                 t32
                 AS _
                 WHERE
                 f0 < 0)
                AS _
                UNION
                SELECT *
                FROM
                (SELECT NULL::integer as f0, f0 as f1 FROM t32 AS _ WHERE f0 >= 0)
                AS _)
               AS _)
              AS _)
             AS _
             CROSS JOIN
             (SELECT f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5 FROM t29 AS _))
            AS _)
           SELECT *
           FROM
           (WITH t34 AS
            (SELECT *
             FROM
             (SELECT *
              FROM
              (SELECT
               f0 AS f0, f1 AS f1
               FROM
               (SELECT f0 AS f0, f1 AS f1 FROM t31 AS _)
               AS _)
              AS _
              CROSS JOIN
              (SELECT
               f0 AS f2, f1 AS f3, f2 AS f4, f3 AS f5, f4 AS f6, f5 AS f7
               FROM
               t31
               AS _))
             AS _)
            SELECT *
            FROM
            (WITH t35 AS
             (SELECT *
              FROM
              (-- dist
               SELECT *
               FROM
               (SELECT
                f0 AS f0, f2 AS f1, NULL::integer AS f10, NULL::integer AS f11, NULL::integer AS f12, NULL::integer AS f13, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5, f7 AS f6, NULL::integer AS f7, NULL::integer AS f8, NULL::integer AS f9
                FROM
                (-- dist1
                 SELECT * FROM t34 AS _ WHERE "f0" IS NOT NULL)
                AS _)
               AS _
               UNION
               SELECT *
               FROM
               (SELECT
                NULL::integer AS f0, NULL::integer AS f1, f4 AS f10, f5 AS f11, f6 AS f12, f7 AS f13, NULL::integer AS f2, NULL::integer AS f3, NULL::integer AS f4, NULL::integer AS f5, NULL::integer AS f6, f1 AS f7, f2 AS f8, f3 AS f9
                FROM
                (-- dist2
                 SELECT * FROM t34 AS _ WHERE "f1" IS NOT NULL)
                AS _)
               AS _)
              AS _)
             SELECT *
             FROM
             (SELECT *
              FROM
              (SELECT
               NULL::integer AS f0, f0 AS f1
               FROM
               (SELECT
                f0 + f1 AS f0
                FROM
                (WITH t36 AS
                 (SELECT *
                  FROM
                  (SELECT
                   f0 AS f0, f1 AS f1, f2 AS f2, f3 AS f3, f4 AS f4, f5 AS f5, f6 AS f6
                   FROM
                   (-- join1
                    SELECT * FROM t35 AS _
                    WHERE
                    ("f0" IS NOT NULL) AND ((("f1" IS NOT NULL) OR ("f2" IS NOT NULL)) AND (("f3" IS NOT NULL) AND ((("f4" IS NOT NULL) OR ("f5" IS NOT NULL)) AND ("f6" IS NOT NULL)))))
                   AS _)
                  AS _)
                 SELECT *
                 FROM
                 (SELECT *
                  FROM
                  (SELECT
                   f0 AS f0
                   FROM
                   (SELECT
                    f0 AS f0
                    FROM
                    (SELECT
                     f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                     FROM
                     (SELECT
                      f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                      FROM
                      t36
                      AS _)
                     AS _)
                    AS _)
                   AS _)
                  AS _
                  CROSS JOIN
                  (SELECT f0 AS f1 FROM (SELECT 1 as f0 FROM t36 AS _) AS _))
                 AS _)
                AS _)
               AS _)
              AS _
              UNION
              SELECT *
              FROM
              (SELECT
               f0 AS f0, NULL::integer AS f1
               FROM
               (SELECT
                f0 AS f0
                FROM
                (SELECT
                 f2 AS f0, f3 AS f1, f4 AS f2, f5 AS f3
                 FROM
                 (SELECT
                  f1 AS f0, f2 AS f1, f3 AS f2, f4 AS f3, f5 AS f4, f6 AS f5
                  FROM
                  (SELECT
                   f7 AS f0, f8 AS f1, f9 AS f2, f10 AS f3, f11 AS f4, f12 AS f5, f13 AS f6
                   FROM
                   (-- join2
                    SELECT * FROM t35 AS _
                    WHERE
                    ("f7" IS NOT NULL) AND ((("f8" IS NOT NULL) OR ("f9" IS NOT NULL)) AND (("f10" IS NOT NULL) AND ((("f11" IS NOT NULL) OR ("f12" IS NOT NULL)) AND ("f13" IS NOT NULL)))))
                   AS _)
                  AS _)
                 AS _)
                AS _)
               AS _)
              AS _)
             AS _)
            AS _)
           AS _)
          AS _)
         AS _)
        AS _)
       AS _
       CROSS JOIN
       (SELECT f0 AS f2 FROM (SELECT f2 AS f0 FROM t26 AS _) AS _))
      AS _)
     SELECT *
     FROM
     (-- dist
      SELECT *
      FROM
      (SELECT
       f0 AS f0, f2 AS f1, NULL::integer AS f2, NULL::integer AS f3
       FROM
       (-- dist1
        SELECT * FROM t27 AS _ WHERE "f0" IS NOT NULL)
       AS _)
      AS _
      UNION
      SELECT *
      FROM
      (SELECT
       NULL::integer AS f0, NULL::integer AS f1, f1 AS f2, f2 AS f3
       FROM
       (-- dist2
        SELECT * FROM t27 AS _ WHERE "f1" IS NOT NULL)
       AS _)
      AS _)
     AS _)
    AS _)
   AS _)
  AS _
  WHERE
  ("f0" IS NOT NULL) AND ("f1" IS NOT NULL))
 AS _)
AS _;

It’s not pretty, rather amazingly, running the above query in postgres 17 will in fact return a single row with a single column whose value is 100. And you’d better believe it does it by actually looping its way up to 100. If you don’t believe me, make the following change:

-     SELECT * FROM recursion ORDER BY step DESC LIMIT 1)
+     SELECT * FROM recursion ORDER BY step DESC)

which will instead return a row for each step of the iteration.

There are some obvious optimizations I could make to the generated SQL, but it didn’t seem worth my time, since that’s not the interesting part of the project.

What the Hell Is Going On?

Let’s take some time to discuss the underlying category theory here. I am by no means an expert, but what I have learned after a decade of bashing my head against this stuff is that a little goes a long way.

For our intents and purposes, we have types, and arrows (functions) between types. We always have the identity “do nothing arrow” id:

id  :: a ~> a

and we can compose arrows by lining up one end to another:¹

(⨟) :: (a ~> b) -> (b ~> c) -> (a ~> c)

Unlike Haskell (or really any programming language, for that matter), we DO NOT have the notion of function application. That is, there is no arrow:

-- doesn't exist!
($) :: (a ~> b) -> a -> b

You can only compose arrows, you can’t apply them. That’s why we call these things “arrows” rather than “functions.”

There are a bundle of arrows for working with product types. The two projection functions correspond to fst and snd, taking individual components out of pairs:

prj₁ :: (a, b) ~> a
prj₂ :: (a, b) ~> b

How do we get things into pairs in the first place? We can use the “fork” operation, which takes two arrows computing b and c, and generates a new arrow which generates a pair of (b, c):

(△)  :: (a ~> b) -> (a ~> c) -> (a ~> (b, c))

If you’re coming from a Haskell background, it’s tempting to think of this operation merely as the (,) pair constructor. But you’ll notice from the type of the computation that there can be no data dependency between b and c, thus we are free to parallelize each side of the pair.

In category theory, the distinction between left and right sides of an arrow is rather arbitrary. This gives rise to a notion called duality where we can flip the arrows around, and get cool new behavior. If we dualize all of our product machinery, we get the coproduct machinery, where a coproduct of a and b is “either a or b, but definitely not both nor neither.”

Swapping the arrow direction of prj₁ and prj₂, and replacing (,) with Either gives us the following injections:

inl :: a ~> Either a b
inr :: b ~> Either a b

and the following “join” operation for eliminating coproducts:

(▽) :: (a ~> c) -> (b ~> c) -> (Either a b ~> c)

Again, coming from Haskell this is just the standard either function. It corresponds to a branch between one of two cases.

As you can see, with just these eight operations, we already have a tremendous amount of expressivity. We can express data dependencies via ⨟ and branching via ▽. With △ we automatically encode opportunities for parallelism, and gain the ability to build complicated data structures, with prj₁ and prj₂ allowing us to get the information back out of the data structures.

You’ll notice in the IL that there are no variable names anywhere to be found. The desugaring of the source language builds a stack (via the something to allocate △ id pattern), and replaces subsequent variable lookups with a series of projections on the stack to find the value again. On one hand, this makes the categorical IL rather hard to read, but it makes it very easy to re-target! Many domains do have a notion of grouping, but don’t have a native notion of naming.

For example, in an electronic circuit, I can have a ribbon of 32 wires which represents an Int32. If I have another ribbon of 32 wires, I can trivially route both wires into a 64-wire ribbon corresponding to a pair of (Int32, Int32).

By eliminating names before we get to the IL, it means no compiler backend ever needs to deal with names. They can just work on a stack representation, and are free to special-case optimize series of projections if they are able to.

Of particular interest to this discussion is how we desugar loops in catlang. The underlying primitive is cochoice:

cochoice :: (Either a c ~> Either b c) -> (a ~> b)

which magically turns an arrow on Eithers into an arrow without the eithers. We obviously must run that arrow on eithers. If that function returns inl, then we’re happy and we can just output that. But if the function returns inr, we have no choice but to pass it back in to the eithered arrow. In Haskell, cochoice is implemented as:

cochoiceHask :: (Either a c -> Either b c) -> a -> c
cochoiceHask f = go . Left
  where
    go :: Either a c -> b
    go eac =
      case f eac of
        Left b -> b
        Right c -> go (Right c)

which as you can see, will loop until f finally returns a Left. What’s neat about this formulation of a loop is that we can statically differentiate between our first and subsequent passes through the loop body. The first time through eac is Left, while for all other times it is Right. We don’t take advantage of it in the original count program, but how many times have you written loop code that needs to initialize something its first time through?

Compiling to SQL

So that’s the underlying theory behind the IL. How can we compile this to SQL now?

As alluded to before, we simply need to give SQL implementations for each of the operations in the intermediary language. As a simple example, id compiles to SELECT * FROM {}, where {} is the input of the arrow.

The hardest part here was working out a data representation. It seems obvious to encode each element of a product as a new column, but what do we do about coproducts? After much work thought, I decided to flatten out the coproducts. So, for example, the type:

(Int, Either Int Int)

would be represented as three columns:

( f1 INT NOT NULL
, f2 INT
, f3 INT
)

with the constraint that exactly one of f2 or f3 would be IS NOT NULL at any given point in time.

With this hammered out, almost everything else is pretty trivial. Composition corresponds to a nested query. Forks are CROSS JOINs which concatenate the columns of each sub-query. Joins are UNIONs, where we add a WHERE field IS NOT NULL clause to enforce we’re looking at the correct coproduct constructor.

Cochoice is the only really tricky thing, but it corresponds to a recursive CTE. Generating a recursive CTE table for the computation isn’t too hard, but getting the final value out of it was surprisingly tricky. The semantics of SQL tables is that they are multisets and come with an arbitrary greatest element. Which is to say, you need an column structured in a relevant way in order to query the final result. Due to some quirks in what postgres accepts, and in how I structured my queries, it was prohibitively hard to insert a “how many times have I looped” column and order by that. So instead I cheated and added a clock_timestamp() as step column which looks at the processor clock and ordered by that.

This is clearly a hack, and presumably will cause problems if I ever add some primitives which generate more than one row, but again, this is just for fun and who cares. Send me a pull request if you’re offended by my chicanery!

Stupid Directions To Go In the Future

I’ve run out of vacation time to work on this project, so I’m probably not going to get around to the meta-circular stupidity I was planning.

The compiler still needs a few string-crunching primitives (which are easy to add), but then it would be simple to write a little brainfuck interpreter in catlang. Which I could then compile to SQL. Now we’ve got a brainfuck interpreter running in postgres. Of course, this has been done by hand before, but to my knowledge, never via compilation.

There exist C to brainfuck compilers. And postgres is written in C. So in a move that would make Xzibit proud, we could run postgres in postgres. And of course, it would be fun to run brainfuck in brainfuck. That’d be a cool catlang backend if someone wanted to contribute such a thing.

Notes and Due Diligence and What Have You

I am not the first person to do anything like this. The source language of catlang is heavily inspired by Haskell’s arrow syntax, which in turn is essentially a desugaring algorithm for Arrows. Arrows are slightly the wrong abstraction because they require an operation arr :: (a -> b) -> (a ~> b)—which requires you to be able to embed Haskell functions in your category, something which is almost never possible.

Unfortunately, arrow syntax in Haskell desugars down to arr for almost everything it does, which in turn makes arrow notation effectively useless. In an ideal world, everything I described in this blog post would be a tiny little Haskell library, with arrow notation doing the heavy lifting. But that is just not the world we live in.

Nor am I the first person to notice that there are categorical semantics behind programming languages. I don’t actually know whom to cite on this one, but it is well-established folklore that the lambda calculus corresponds to cartesian-closed categories. The “closed” part of “cartesian-closed” means we have an operation eval :: (a ~> b, a) ~> b, but everyone and their dog has implemented the lambda calculus, so I thought it would be fun to see how far we can get without it. This is not a limitation on catlang’s turing completeness (since cochoice gives us everything we need.)

I’ve been thinking about writing a category-first programming language for the better part of a decade, ever since I read Compiling to Categories. That paper takes Haskell and desugars it back down to categories. I stole many of the tricks here from that paper.

Anyway. All of the code is available on github if you’re interested in taking a look. The repo isn’t up to my usual coding standards, for which you have my apologies. Of note is the template-haskell backend which can spit out Haskell code; meaning it wouldn’t be very hard to make a quasiquoter to compile catlang into what Haskell’s arrow desugaring ought to be. If there’s enough clamor for such a thing, I’ll see about turning this part into a library.

---

1. When looking at the types of arrows in this essay, we make the distinction that ~> are arrows that we can write in catlang, while -> exist in the metatheory.↩︎

October 14, 2025 02:31 PM