Tuesday, March 29, 2022

Modeling PlusCal in Haskell using Cartesian products of NFAs

Modeling PlusCal in Haskell using Cartesian products of NFAs

PlusCal is a formal specification language created to model concurrent systems, and recently I became obsessed with implementing PlusCal as an embedded domain-specific language (eDSL) in Haskell. In other words, I want to model PlusCal processes as Haskell subroutines and also implement the model checker in Haskell.

I’m not done implementing this PlusCal eDSL, but I’m writing this to share what I learned in the course of doing so. Specifically, what I learned was:

  • You can model individual PlusCal processes as non-deterministic finite-state automata (NFAs)

    I believe this is well-understood by users of PlusCal, but I’m mentioning this for people who are new to PlusCal.

  • You can model concurrent processes in PlusCal by computing the Cartesian product of their NFAs

    I’m not sure if this is widely understood or not.

  • Haskell’s Applicative abstraction can compute Cartesian products of NFAs

    This is the novel insight that this post contributes.

There are two reasons why I’m keen on modeling PlusCal using Cartesian products of NFAs:

  • We can use this trick to combine any number of PlusCal processes into a composite process

    The behavior of this composite process is indistinguishable from the original collection of processes.

  • This approach simplifies the implementation of the model checker

    The model checker now only needs to accept a single process as its input. To model check more than one process you compose them into a single process and model check the composite process.

Also, it’s a theoretically elegant solution, and that’s good enough for me.

Scope

Like I mentioned before, I have not fully implemented all of PlusCal, but here are the features I will explain how to implement in this post:

  • Concurrent processes

    Concurrent processes in PlusCal are essentially NFAs where PlusCal labels correspond to NFA states and state transitions represent atomic process changes.

    To be pedantic, a PlusCal process is an NFA where the transitions are not labeled (or, equivalently, there is only one input symbol).

  • Labels

    These are breakpoints within a PlusCal process where the process may be interrupted by another process. All other actions are uninterruptible, so anything that happens between two successive labels is atomic in PlusCal.

    Note that a label in PlusCal is not the same as a label in traditional NFA terminology. PlusCal labels correspond to NFA states.

  • The either keyword

    PlusCal lets a process non-deterministically branch using the either keyword with one nested subroutine per branch. The model checker explores and verify all possible branches.

  • The with keyword

    A process can non-deterministically choose from zero or more values. Just like with either the model checker explores and verifies all possible choices.

  • The await keyword

    A process can wait until a condition is satisfied before proceeding using the await keyword.

  • The while keyword

    A process can run in a loop until a condition is satisfied

  • The skip keyword

    A process can skip, which does nothing.

I am not (yet) explaining how to implement the following parts of PlusCal:

  • Global or process-local state

  • Temporal expressions

    Note that there is a Haskell package named spectacle for temporal logic in Haskell that a coworker of mine published, which I might be able to use for this purpose, but I haven’t attempted to incorporate that, yet.

  • The print keyword

  • The assert keyword

  • The goto keyword

  • The model checker

    We need to be able to model temporal expressions in order to implement the model checker and I haven’t yet incorporated temporal expressions into my implementation.

I believe the implementation I describe in this post can be extended with those missing features (with the exception of goto) and I’ve already privately implemented some of them. However, I omit them because they would interfere with the subject of this post.

Also, some PlusCal features we’ll get for free by virtue of embedding PlusCal in Haskell:

  • (Non-temporal) Expressions

    We get all of TLA+’s non-temporal functionality (e.g. scalars, functions, composite data structures) for free from the Haskell language and its standard library. Plus we also access new functionality (such as algebraic data types) via Haskell.

  • Procedures (including the call and return keyword)

    We won’t need to explicitly implement support for these keywords. We can already define and invoke procedures in Haskell using do notation, which we can overload to work with PlusCal processes.

  • Modules

    We can model PlusCal modules using a combination of Haskell modules and Haskell functions.

User experience

The best way to illustrate what I have in mind is through some sample working Haskell code.

First, I’d like to be able to translate a PlusCal process like this:

begin
A:
  skip;
B:
  either
    C:
      skip;
  or
    skip;
  end either;
D:
  skip;
end process

… into a Haskell process like this:

strings :: Coroutine String
strings = Begin "A" do
    yield "B"
    either
        [ yield "C"
        , skip
        ]
    yield "D"
    end

The type of our strings process is Coroutine String, meaning that it is a Coroutine whose labels are Strings. The reason we specify the type of the labels is because the Haskell eDSL permits labels of any type and these labels might not necessarily be strings.

For example, suppose PlusCal permitted integers for labels, like this:

begin
0:
  with x \in { 1, 2, 3 } do
    await (x % 2 = 0);
    x: (* Suppose we can even create dynamic labels from values in scope *)
      skip;
end process

Then, the equivalent Haskell process would be:

ints :: Coroutine Int
ints = Begin 0 do
    x <- with [ 1, 2, 3 ]
    await (even x)
    yield x
    end

I mentioned in the introduction that we will be able to combine processes into a composite process, which looks like this:

pairs :: Coroutine (String, Int)
pairs = do
    string <- strings
    int    <- ints
    return (string, int)

The Haskell code evaluates those three processes to canonical normal forms representing the evolution of labels for each process.

For example, the canonical normal form for the strings process is:

Begin "A" [ Yield "B" [ Yield "C" [ Yield "D" [] ] , Yield "D" [] ] ]

… representing the following NFA with these labels and transitions:

A → B → D
     ↘ ↗
      C

In other words, this normal form data structure uses lists to model non-determinism (one list element per valid transition) and nesting to model sequential transitions.

Similarly, the canonical normal form for the ints process is:

Begin 0 [ Yield 2 [] ]

… representing the following NFA with these labels and transitions:

0
↓
2

Finally, the canonical normal form for the composite pairs process is:

Begin ( "A" , 0 )
  [ Yield ( "B" , 0 )
      [ Yield ( "C" , 0 )
          [ Yield ( "D" , 0 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          ]
      , Yield ( "D" , 0 ) [ Yield ( "D" , 2 ) [] ]
      , Yield ( "B" , 2 )
          [ Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "D" , 2 ) []
          ]
      ]
  , Yield ( "A" , 2 )
      [ Yield ( "B" , 2 )
          [ Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "D" , 2 ) []
          ]
      ]
  ]

… which is the Cartesian product of the two smaller NFAs:

(A,0) → (B,0)   →   (D,0)
             ↘     ↗
              (C,0)    
  ↓       ↓     ↓     ↓
              (C,2)
             ↗     ↘
(A,2) → (B,2)   →   (D,2)

… and if we convert the Haskell composite process to the equivalent PlusCal process we would get:

begin
  (A,0):
    skip;
  either
    (B,0):
      either
        (C,0):
          either
            (D,0):
              skip;
            (D,2):
              skip;
          or
            (C,2):
              skip;
            (D,2):
              skip;
          end either;
      or
        (D,0):
          skip;
        (D,2):
          skip;
      end either;
  or
    (A,2):
      skip;
    (B,2):
      skip;
    either
      (C,2):
        skip;
      (D,2):
        skip;
    or
      (D,2):
        skip;
    end either;
  end either;
end process

This composite process is indistinguishable from the two input processes, meaning that:

  • This composite process is interruptible whenever one of the two original input processes is interruptible

  • This composite process performs an atomic state transition whenever one of the two input processes performs a state transition

  • The current label of the composite process is a function of the current label of the two original input processes

The Process type

Now I’ll explain how to implement this subset of PlusCal as an eDSL in Haskell.

First, we begin from the following two mutually-recursive types which represent NFAs where there are zero more labeled states but the transitions are unlabeled:

newtype Process label result = Choice [Step label result]

data Step label result = Yield label (Process label result) | Done result

The Process type handles the non-deterministic transitions for our NFA: a Process stores zero or more valid state transitions (represented as a list of valid next Steps).

The Step type handles the labeled states for our NFA: a Step can either Yield or be Done:

  • A step that Yields includes the label for the current state and the remainder of the Process

  • A step that is Done includes a result

    This result is used to thread data bound by one step to subsequent steps. For example, this is how our previous example was able to pass the x bound by with to the subsequent yield command:

    ints = Begin 0 do
        x <- with [ 1, 2, 3 ]
    
        yield x
    

We’ll add support for rendering the data structures for debugging purposes:

{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances       #-}

import GHC.Exts (IsList(..))

newtype Process label result = Choice [Step label result]
    deriving newtype (IsList, Show)

data Step label result = Yield label (Process label result) | Done result
    deriving stock (Show)

I make use of a small trick here where I derive IsList for the Process type This lets can omit the Choice constructor when creating or rendering values of type Process. That simplifies Haskell code like this:

Begin "A"
  (Choice
     [ Yield "B"
         (Choice
            [ Yield "C" (Choice [ Yield "D" (Choice []) ])
            , Yield "D" (Choice [])
            ])
     ])

… to this more ergonomic syntax if we enable the OverloadedLists extension:

Begin "A" [ Yield "B" [ Yield "C" [ Yield "D" [] ] , Yield "D" [] ] ]

do notation

However, we don’t expect users to author these data structures by hand. Instead, we can use Haskell’s support for overloading do notation so that users can author Process values using subroutine-like syntax. In order to do this we need to implement the Monad class for Process, like this:

{-# LANGUAGE BlockArguments #-}

import qualified Control.Monad as Monad

instance Monad (Process label) where
    Choice ps >>= f = Choice do
        p <- ps
        case p of
            Yield label rest -> do
                return (Yield label (rest >>= f))
            Done result -> do
                let Choice possibilities = f result
                possibilities

instance Applicative (Process label) where
    pure result = Choice (pure (Done result))

    (<*>) = Monad.ap

instance Functor (Process label) where
    fmap = Monad.liftM

… and we also need to provide the following utility function:

yield :: label -> Process label ()
yield label = Choice [Yield label (pure ())]

Equipped with that Monad instance we can now author code like this:

example :: Process Int ()
example = do
    yield 1
    yield 2
    yield 3

… and that superficially imperative code actually evaluates to a pure data structure:

[ Yield 1 [ Yield 2 [ Yield 3 [ Done () ] ] ] ]

The reason that works is because any type that implements Monad can be sequenced using do notation, because do notation is syntactic sugar for the (>>=) operator we defined in our Monad instance. To learn more, read:

We can also now implement skip, which is just a synonym for pure () (i.e. “do nothing”):

skip :: Process label ()
skip = pure ()

Unlike PlusCal, we don’t need to use skip most of the time. In particular, we don’t need to add a skip in between two labels if nothing happens. For example, suppose we try to translate this PlusCal code:

1:
  skip;
2:
  skip;

… to Haskell:

example :: Process Int ()
example = do
    yield 1
    skip
    yield 2
    skip

We don’t actually need those skips. The following code without skips is the exact same Process:

example :: Process Int ()
example = do
    yield 1
    yield 2

Both ways of writing the Process produce the same result, which is:

[ Yield 1 [ Yield 2 [ Done () ] ] ]

Finally, we can implement the while keyword as an ordinary Haskell function:

while :: Process label Bool -> Process label () -> Process label ()
while condition body = do
    bool <- condition
    Monad.when bool do
        body
        while condition body

In fact, there’s nothing really PlusCal-specific about this utility; this functionality already exists as Control.Monad.Loops.whileM_.

Alternation

So far we can only sequence commands, but we’d also like to be able to branch non-deterministically. Fortunately, Haskell has a standard API for doing that, too, which is the Alternative class. We can implement Alternative for our Process type like this:

import Control.Applicative (Alternative(..))

instance Alternative (Process label) where
    empty = Choice empty

    Choice stepsL <|> Choice stepsR = Choice (stepsL <|> stepsR)

We’ll also define end to be a synonym for empty:

end :: Process label a
end = empty

In other words, if you end a Process there are no more valid transitions.

When we implement this Alternative instance we can make use of several general-purpose utilities that work for any type that implements Alternative. One such utility is Data.Foldable.asum, which behaves exactly the same as PlusCal’s either keyword:

import Prelude hiding (either)

import qualified Data.Foldable as Foldable

either :: [Process label result] -> Process label result
either = Foldable.asum

We could also write the implementation of either by hand if we wanted to, which would be:

either (process : processes) = process <|> either processes
either            []         = empty

… which is exact same behavior as using asum.

In other words, given a list of Processes, we can try all of them in parallel using either. All that either does is concatenate the lists of valid Steps for each of the input Processes.

Control.Monad.guard is another utility we get for free by virtue of implementing Alternative and guard behaves in the exact same way as PlusCal’s await keyword:

await :: Bool -> Process label ()
await = Monad.guard

We could also write the implementation of await by hand if we wanted to, which would be:

await True  = skip
await False = end

… which is the same behavior as using guard.

Finally, we can implement with in terms of either, like this:

with :: [result] -> Process label result
with results = either (map pure results)

In other words, you can implement with as if it were an either statement with one branch per value that you want to bind. However, you have to promote each value to a trivial Process (using pure) in order to combine them using either.

Cartesian product of NFAs

In the introduction I noted that we can model multiple processes in PlusCal by computing the Cartesian product of their NFAs. This section explains that in more detail, first as prose and then followed by Haskell code.

Informally, the Cartesian product of zero or more “input” NFAs creates a composite “output” NFA where:

  • The set of possible states for the output NFA is the Cartesian product of the set of possible states for each input NFA

    In other words, if we have two input NFAs and the first NFA permits the following states:

    [ A, B, C ]

    … and the second NFA permits the following states:

    [ 0, 1, 2 ]

    … then the Cartesian product of those two sets of states is:

    [ (A,0), (B,0), (C,0), (A,1), (B,1), (C,1), (A,2), (B,2), (C,2) ]

    … which is our composite set of possible states.

  • The starting state for our output NFA is the Cartesian product of the starting states for each input NFA

    In other words, if our first NFA has a starting state of:

    A

    … and our second has a starting state of:

    0

    … then the Cartesian product of those two starting states is:

    (A,0)

    … which is our composite starting state.

  • The set of valid transitions for any output state is the union of the set of valid transitions for the input sub-states

    In other words, if the state A can transition to either state B or C:

    [ B, C ]

    … and the state 0 can transition to only state 2:

    [ 2 ]

    … then the state (A,0) can transition to any of these states:

    [ (B, 0), (C, 0), (A, 2) ]

    … and this is because:

    • If state A transitions to state B, then our composite state (A,0) transitions to state (B,0)

    • If state A transitions to state C, then our composite state (B,0) transitions to state (C,0)

    • If state 0 transitions to state 2, then our composite state (A,0) transitions to state (A,2)

Applicative as Cartesian product

Haskell’s standard library defines the following Applicative class:

class Applicative f where
    pure :: a -> f a

    (<*>) :: f (a -> b) -> f a -> f b

…and you can think of Haskell’s Applicative class as (essentially) an interface for arbitrary N-ary Cartesian products, meaning that any type that implements an Applicative instance gets the following family of functions for free:

-- The 0-ary Cartesian product
join0 :: Applicative f => f ()
join0 = pure ()

-- The unary Cartesian product
join1 :: Applicative f => f a -> f a
join1 as = pure id <*> as

-- The binary Cartesian product
join2 :: Applicative f => f a -> f b -> f (a, b)
join2 as bs = pure (,) <*> as <*> bs

-- The trinary Cartesian product
join3 :: Applicative f => f a -> f b -> f c -> f (a, b, c)
join3 as bs cs = pure (,,) <*> as <*> bs <*> cs

… and so on. I deliberately implemented some of those functions in a weird way to illustrate the overall pattern.

This means that if we implement Applicative for our NFA type then we can use that interface to create arbitrary N-ary Cartesian products of NFAs.

The Coroutine type

The Process type does implement an Applicative instance, but this is a different (more boring) Cartesian product and not the one we’re interested in. In fact, the Process type cannot implement the instance we’re interested in (the Cartesian product of NFAs), because our Process type is not a complete NFA: our Process type is missing a starting state.

This is what the following Coroutine type fixes by extending our Process type with an extra field for the starting state:

import Data.Void (Void)

data Coroutine label = Begin label (Process label Void)
    deriving stock (Show)

We also constrain the Process inside of a Coroutine to return Void (the impossible/uninhabited type). Any Process that ends with no valid transitions will satisfy this type, such as a process that concludes with an end or empty:

example :: Coroutine Int
example = Begin 0 do
    yield 1
    yield 2
    end

Once we add in the starting state we can implement Applicative for our Coroutine type, which is essentially the same thing as implementing the Cartesian product of NFAs:

instance Applicative Coroutine where
    -- The empty (0-ary) Cartesian product has only a single valid state, which
    -- is also the starting state, and no possible transitions.
    pure label = Begin label empty

    -- The (sort of) binary Cartesian product …
    (<*>)
        -- … of a first NFA …
        f@(Begin label0F (Choice fs))
        -- … and a second NFA …
        x@(Begin label0X (Choice xs)) =
        Begin
            -- … has a starting state which is (sort of) the product of the
            -- first and second starting states
            (label0F label0X)
            -- … and the set of valid transitions is the union of valid
            -- transitions for the first and second NFAs
            (Choice (fmap adaptF fs <|> fmap adaptX xs))
          where
            -- If the first NFA transitions, then we don't disturb the state
            -- of the second NFA
            adaptF (Done result) = Done result
            adaptF (Yield labelF restF) = Yield labelFX restFX
              where
                Begin labelFX restFX = Begin labelF restF <*> x

            -- If the second NFA transitions, then we don't disturb the state
            -- of the first NFA
            adaptX (Done result) = Done result
            adaptX (Yield labelX restX) = Yield labelFX restFX
              where
                Begin labelFX restFX = f <*> Begin labelX restX

I use “sort of” in the comments to indicate that (<*>) is not actually the binary Cartesian product, but it’s spiritually similar enough.

Moreover, we can reassure ourselves that this Applicative instance is well-behaved because this instance satisfies the Applicative laws. See Appendix D for the proof of all four laws for the above instance.

ApplicativeDo

Haskell is not the only language that defines an Applicative abstraction. For example, the Cats package in the Scala ecosystem also defines an Applicative abstraction, too.

However, the Haskell ecosystem has one edge over other languages (including Scala), which is language support for types that only implement Applicative and not Monad.

Specifically, Haskell has an ApplicativeDo extension, which we can use to combine values for any Applicative type using do notation. In fact, this is why the original example using pairs worked, because of that extension:

{-# LANGUAGE ApplicativeDo #-}

pairs :: Coroutine (String, Int)
pairs = do
    string <- strings
    int    <- ints
    return (string, int)

When we enable that extension the Haskell compiler desugars that do notation to something like this:

pairs = f <$> strings <*> ints
  where
    f string int = (string, int)

… and in my opinion the version using do notation is more readable and ergonomic.

Normally do notation only works on types that implement Monad, but when we enable the ApplicativeDo extension then a subset of do notation works for types that implement Applicative (which is superset of the types that implement Monad).

Our Coroutine type is one such type that benefits from this ApplicativeDo extension. The Coroutine type can implement Applicative, but not Monad, so the only way we can use do notation for Coroutines is if we enable ApplicativeDo.

The ApplicativeDo extension also plays very nicely with Haskell’s support for NamedFieldPuns or RecordWildCards. For example, instead of packing the labels into a tuple we could instead slurp them into a record as fields of the same name:

{-# LANGUAGE RecordWildCards #-}

data Status = Status
    { string :: String
    , int    :: Int
    }

pairs :: Coroutine Status
pairs = do
    string <- strings
    int    <- ints
    return Status{..}

… and this scales really well to a large number of Coroutines.

Conclusion

I’ve included the complete implementation from this post in Appendix A if you want to test this code out on your own. Once I’m done with the complete embedding of PlusCal in Haskell I’ll publish something a bit more polished.

If you enjoyed this post, you’ll probably also enjoy this paper:

… which was the original paper that introduced the Applicative abstraction.

I also left some “bonus commentary” in Appendix B and Appendix C for a few digressions that didn’t quite make the cut for the main body of this post.

Appendix A - Complete implementation

The following module only depends on the pretty-show package (and not even that if you delete the main subroutine).

{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances       #-}

import GHC.Exts (IsList(..))
import Control.Applicative (Alternative(..), liftA2)
import Data.Void (Void)
import Prelude hiding (either)

import qualified Control.Applicative as Applicative
import qualified Control.Monad as Monad
import qualified Data.Foldable as Foldable
import qualified Text.Show.Pretty as Pretty

newtype Process label result = Choice [Step label result]
    deriving newtype (IsList, Show)

data Step label result = Yield label (Process label result) | Done result
    deriving stock (Show)

instance Functor (Process label) where
    fmap = Monad.liftM

instance Applicative (Process label) where
    pure result = Choice (pure (Done result))

    (<*>) = Monad.ap

instance Monad (Process label) where
    Choice ps >>= f = Choice do
        p <- ps
        case p of
            Yield label rest -> do
                return (Yield label (rest >>= f))
            Done result -> do
                let Choice possibilities = f result
                possibilities

instance Semigroup result => Semigroup (Process label result) where
    (<>) = liftA2 (<>)

instance Monoid result => Monoid (Process label result) where
    mempty = pure mempty

instance Alternative (Process label) where
    empty = Choice empty

    Choice stepsL <|> Choice stepsR = Choice (stepsL <|> stepsR)

data Coroutine label = Begin label (Process label Void)
    deriving stock (Show)

instance Functor Coroutine where
    fmap = Applicative.liftA

instance Applicative Coroutine where
    pure label = Begin label empty

    (<*>)
        f@(Begin label0F (Choice fs))
        x@(Begin label0X (Choice xs)) =
        Begin (label0F label0X) (Choice (fmap adaptF fs <|> fmap adaptX xs))
          where
            adaptF (Done result) = Done result
            adaptF (Yield labelF restF) = Yield labelFX restFX
              where
                Begin labelFX restFX = Begin labelF restF <*> x

            adaptX (Done result) = Done result
            adaptX (Yield labelX restX) = Yield labelFX restFX
              where
                Begin labelFX restFX = f <*> Begin labelX restX

instance Semigroup label => Semigroup (Coroutine label) where
    (<>) = liftA2 (<>)

instance Monoid label => Monoid (Coroutine label) where
    mempty = pure mempty

yield :: label -> Process label ()
yield label = Choice [Yield label (pure ())]

either :: [Process label result] -> Process label result
either = Foldable.asum

await :: Bool -> Process label ()
await = Monad.guard

with :: [result] -> Process label result
with results = either (map pure results)

end :: Process label a
end = empty

skip :: Process label ()
skip = mempty

strings :: Coroutine String
strings = Begin "A" do
    yield "B"
    either
        [ yield "C"
        , skip
        ]
    yield "D"
    end

ints :: Coroutine Int
ints = Begin 0 do
    x <- with [ 1, 2, 3 ]
    await (even x)
    yield x
    end

pairs :: Coroutine (String, Int)
pairs = do
    string <- strings
    int    <- ints
    return (string, int)

main :: IO ()
main = do
    Pretty.pPrint strings
    Pretty.pPrint ints
    Pretty.pPrint pairs

If you run that it will print:

Begin
  "A" [ Yield "B" [ Yield "C" [ Yield "D" [] ] , Yield "D" [] ] ]
Begin 0 [ Yield 2 [] ]
Begin
  ( "A" , 0 )
  [ Yield
      ( "B" , 0 )
      [ Yield
          ( "C" , 0 )
          [ Yield ( "D" , 0 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          ]
      , Yield ( "D" , 0 ) [ Yield ( "D" , 2 ) [] ]
      , Yield
          ( "B" , 2 )
          [ Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "D" , 2 ) []
          ]
      ]
  , Yield
      ( "A" , 2 )
      [ Yield
          ( "B" , 2 )
          [ Yield ( "C" , 2 ) [ Yield ( "D" , 2 ) [] ]
          , Yield ( "D" , 2 ) []
          ]
      ]
  ]

Appendix B - Free Monads

The implementation for Process is actually a special case of a free monad transformer, except that I’ve hand-written the types and instances so that the types are easier to inspect. However, if we really wanted to code golf all of this we could have replaced all of that code with just these three lines:

import Control.Monad.Trans.Free (FreeT, liftF)

type Process label = FreeT ((,) label) []

yield label = liftF (label, ())

… and that would have behaved the exact same (including the same Monad and Alternative instances). You can read that as essentially saying: “A Process is a subroutine that alternates between emitting a label (i.e. (,) label) and branching non-deterministically (i.e. [])”.

Appendix C - Monoid / Semigroup

If we want to be extra clever, we can implement Semigroup and Monoid instances for Process as suggested in this post:

… which we would do like this:

import Control.Applicative (liftA2)

instance Semigroup result => Semigroup (Process label result) where
    (<>) = liftA2 (<>)
    
instance Monoid result => Monoid (Process label result) where
    mempty = pure mempty

… and then we can simplify skip a tiny bit further to:

skip = mempty

Appendix D - Proof of the Applicative laws

The first Applicative law requires that:

pure id <*> v = v

Proof:

pure id <*> v

-- Definition of `pure`:
--
-- pure label = Begin label empty
= Begin id empty <*> v

-- Define:
--
-- v = Begin label0X (Choice xs)
= Begin id empty <*> Begin label0X (Choice xs)

-- Definition of `(<*>)`
= Begin (id label0X) (Choice (fmap adaptF empty <|> fmap adaptX xs))
  where
    adaptF (Done result) = Done result
    adaptF (Yield labelF restF) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin labelF restF <*> Begin label0X (Choice xs)

    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin id empty <*> Begin labelX restX

-- fmap f empty = empty
= Begin (id label0X) (Choice (empty <|> fmap adaptX xs))
  where
    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin id empty <*> Begin labelX restX

-- empty <|> xs = xs
= Begin (id label0X) (Choice (fmap adaptX xs))
  where
    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin id empty <*> Begin labelX restX

-- Definition of `pure`, in reverse
--
-- pure label = Begin label empty
= Begin (id label0X) (Choice (fmap adaptX xs))
  where
    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = pure id <*> Begin labelX restX

-- Induction: pure id <*> v = v
= Begin (id label0X) (Choice (fmap adaptX xs))
  where
    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin labelX restX

-- Simplify
= Begin (id label0X) (Choice (fmap adaptX xs))
  where
    adaptX (Done result) = Done result
    adaptX (Yield labelX restX) = Yield labelX restX

-- Simplify
= Begin (id label0X) (Choice (fmap adaptX xs))
  where
    adaptX = id

-- Functor identity law:
--
-- fmap id = id
= Begin (id label0X) (Choice (id xs))

-- Definition of `id`:
--
-- id x = x
= Begin label0X (Choice xs)

-- Definition of `v`, in reverse
--
-- v = Begin label0X (Choice xs)
= v

The second Applicative law requires that:

pure (.) <*> u <*> v <*> w = u <*> (v <*> w)

Proof:

pure (.) <*> u <*> v <*> w

-- Define:
--
-- u = Begin label0U (Choice us)
-- v = Begin label0V (Choice vs)
-- w = Begin label0W (Choice ws)
=     pure (.)
  <*> Begin label0U (Choice us)
  <*> Begin label0V (Choice vs)
  <*> Begin label0W (Choice ws)

-- Definition of `pure`:
=     Begin (.) empty
  <*> Begin label0U (Choice us)
  <*> Begin label0V (Choice vs)
  <*> Begin label0W (Choice ws)

-- Definition of `(<*>)`
=     Begin ((.) label0U) (Choice (fmap adaptF empty <|> fmap adaptU us))
  <*> Begin label0V (Choice vs)
  <*> Begin label0W (Choice ws)
  where
    adaptF (Done result) = Done result
    adaptF (Yield labelF restF) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin labelF restF <*> Begin label0U (Choice us)

    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFU restFU
      where
        Begin labelFU restFU = Begin (.) empty <*> Begin labelU restU

-- fmap f empty = empty
=     Begin ((.) label0U) (Choice (fmap adaptU us))
  <*> Begin label0V (Choice vs)
  <*> Begin label0W (Choice ws)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFU restFU
      where
        Begin labelFU restFU = Begin (.) empty <*> Begin labelU restU

-- Definition of `(<*>)`
=     Begin (label0U . label0V)
          (Choice (fmap adaptFU (fmap adaptU us) <|> fmap adaptV vs))
  <*> Begin label0W (Choice ws)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFU restFU
      where
        Begin labelFU restFU = Begin (.) empty <*> Begin labelU restU

    adaptFU (Done result) = Done result
    adaptFU (Yield labelFU restFU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
            Begin labelFU restFU <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin ((.) label0U) (Choice (fmap adaptU us))
            <*> Begin labelV restV

-- Definition of `(<*>)`, in reverse
=     Begin (label0U . label0V)
          (Choice (fmap adaptFU (fmap adaptU us) <|> fmap adaptV vs))
  <*> Begin label0W (Choice ws)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFU restFU
      where
        Begin labelFU restFU = Begin (.) empty <*> Begin labelU restU

    adaptFU (Done result) = Done result
    adaptFU (Yield labelFU restFU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
            Begin labelFU restFU <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

-- fmap f (fmap g x) = fmap (f . g) x
=     Begin (label0U . label0V)
          (Choice (fmap (adaptFU . adaptU) us <|> fmap adaptV vs))
  <*> Begin label0W (Choice ws)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFU restFU
      where
        Begin labelFU restFU = Begin (.) empty <*> Begin labelU restU

    adaptFU (Done result) = Done result
    adaptFU (Yield labelFU restFU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
            Begin labelFU restFU <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

-- Consolidate (adaptFU . adaptU)
=     Begin (label0U . label0V) (Choice (fmap adaptU us <|> fmap adaptV vs))
  <*> Begin label0W (Choice ws)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

-- Definition of `(<*>)`
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptFUV (fmap adaptU us <|> fmap adaptV vs)
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

    adaptFUV (Done result) = Done result
    adaptFUV (Yield labelFUV restFUV) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin labelFUV restFUV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin (label0U . label0V)
                    (Choice (fmap adaptU us <|> fmap adaptV vs))
            <*> Begin labelW restW

-- Definition of `(<*>)`, in reverse
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptFUV (fmap adaptU us <|> fmap adaptV vs)
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

    adaptFUV (Done result) = Done result
    adaptFUV (Yield labelFUV restFUV) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin labelFUV restFUV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin label0V (Choice vs)
            <*> Begin labelW restW

-- fmap f (x <|> y) = fmap f x <|> fmap f y
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptFUV (fmap adaptU us)
              <|> fmap adaptFUV (fmap adaptV vs)
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

    adaptFUV (Done result) = Done result
    adaptFUV (Yield labelFUV restFUV) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin labelFUV restFUV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin label0V (Choice vs)
            <*> Begin labelW restW

-- fmap f (fmap g x) = fmap (f . g) x
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap (adaptFUV . adaptU) us
              <|> fmap (adaptFUV . adaptV) vs
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV

    adaptFUV (Done result) = Done result
    adaptFUV (Yield labelFUV restFUV) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin labelFUV restFUV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin label0V (Choice vs)
            <*> Begin labelW restW

-- Consolidate (adaptFUV . adaptU) and (adaptFUV . adaptV)
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptU us
              <|> fmap adaptV vs
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)
            <*> Begin label0W (Choice ws)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin (.) empty
            <*> Begin label0U (Choice us)
            <*> Begin label0V (Choice vs)
            <*> Begin labelW restW

-- Definition of `pure`, in reverse
--
-- pure label = Begin label empty
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptU us
              <|> fmap adaptV vs
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                pure (.)
            <*> Begin labelU restU
            <*> Begin label0V (Choice vs)
            <*> Begin label0W (Choice ws)

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                pure (.)
            <*> Begin label0U (Choice us)
            <*> Begin labelV restV
            <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                pure (.)
            <*> Begin label0U (Choice us)
            <*> Begin label0V (Choice vs)
            <*> Begin labelW restW

-- Induction: pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
=     Begin (label0U (label0V label0W))
          (Choice
              (   fmap adaptU us
              <|> fmap adaptV vs
              <|> fmap adaptW ws
              )
          )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin labelU restU
            <*> (   Begin label0V (Choice vs)
                <*> Begin label0W (Choice ws)
                )

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelFUV restFUV
      where
        Begin labelFUV restFUV =
                Begin label0U (Choice us)
            <*> (   Begin labelV restV
                <*> Begin label0W (Choice ws)
                )

    adaptW (Done result) = Done result
    adaptW (Yield labelW restW) = Yield labelFUVW restFUVW
      where
        Begin labelFUVW restFUVW =
                Begin label0U (Choice us)
            <*> (   Begin label0V (Choice vs)
                <*> Begin labelW restW
                )

-- Unfactor up `adaptV` into `adaptVW . adaptV` and `adaptW` into
-- `adaptVW . adaptW`
= Begin (label0U (label0V label0W))
      (Choice
          (   fmap adaptU us
          <|> fmap adaptVW (fmap adaptV vs)
          <|> fmap adaptVW (adaptW ws)
          )
      )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin labelU (Choice us)
            <*> (   Begin label0V (Choice vs)
                <*> Begin label0W (Choice ws)
                )

    adaptVW (Done result) = Done result
    adaptVW (Yield labelVW restVW) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin label0U (Choice us)
            <*> Begin labelVW restVW

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelVW restVW
      where
        Begin labelVW restVW = Begin labelV restV <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptV (Yield labelW restW) = Yield labelVW restVW
      where
        Begin lableVW restVW = Begin label0V (Choice vs) <*> Begin labelW restW

-- fmap f (x <|> y) = fmap f x <|> fmap f y
= Begin (label0U (label0V label0W))
      (Choice
          (   fmap adaptU us
          <|> fmap adaptVW (fmap adaptV vs <|> fmap adaptW ws)
          )
      )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin labelU (Choice us)
            <*> (   Begin label0V (Choice vs)
                <*> Begin label0W (Choice ws)
                )

    adaptVW (Done result) = Done result
    adaptVW (Yield labelVW restVW) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin label0U (Choice us)
            <*> Begin labelVW restVW

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelVW restVW
      where
        Begin labelVW restVW = Begin labelV restV <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptV (Yield labelW restW) = Yield labelVW restVW
      where
        Begin lableVW restVW = Begin label0V (Choice vs) <*> Begin labelW restW

-- Definition of `(<*>)`
= Begin (label0U (label0V label0W))
      (Choice
          (   fmap adaptU us
          <|> fmap adaptVW (fmap adaptV vs <|> fmap adaptW ws)
          )
      )
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin labelU (Choice us)
            <*> Begin (label0V label0W)
                    (Choice (fmap adaptV vs <|> fmap adaptW ws))

    adaptVW (Done result) = Done result
    adaptVW (Yield labelVW restVW) = Yield labelUVW restUVW
      where
        Begin labelUVW restUVW =
                Begin label0U (Choice us)
            <*> Begin labelVW restVW

    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelVW restVW
      where
        Begin labelVW restVW = Begin labelV restV <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptV (Yield labelW restW) = Yield labelVW restVW
      where
        Begin lableVW restVW = Begin label0V (Choice vs) <*> Begin labelW restW

-- Definition of `(<*>)`, in reverse
=     Begin label0U (Choice us)
  <*> Begin (label0V label0W)
          (Choice (fmap adaptV vs <|> fmap adaptW ws))
  where
    adaptV (Done result) = Done result
    adaptV (Yield labelV restV) = Yield labelVW restVW
      where
        Begin labelVW restVW = Begin labelV restV <*> Begin label0W (Choice ws)

    adaptW (Done result) = Done result
    adaptV (Yield labelW restW) = Yield labelVW restVW
      where
        Begin lableVW restVW = Begin label0V (Choice vs) <*> Begin labelW restW

-- Definition of `(<*>)`, in reverse
=     Begin label0U (Choice us)
  <*> (   Begin label0V (Choice vs)
      <*> Begin label0W (Choice ws)
      )

-- Definition of `u`, `v`, `w`, in reverse:
--
-- u = Begin label0U (Choice us)
-- v = Begin label0V (Choice vs)
-- w = Begin label0W (Choice ws)
= u <*> (v <*> w)

The third Applicative law requires that:

pure f <*> pure x = pure (f x)

Proof:

pure f <*> pure x

-- Definition of `pure`
--
-- pure label = Begin label empty
= Begin f empty <*> Begin x empty

-- Definition of `(<*>)`
= Begin (f x) (fmap adaptF empty <|> fmap adaptX empty)
  where
    adaptF (Done resultF) = Done resultF
    adaptF (Yield labelF restF) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin labelF restF <*> Begin x empty

    adaptX (Done resultX) = Done resultX
    adaptX (Yield labelX restX) = Yield labelFX restFX
      where
        Begin labelFX restFX = Begin f empty <*> Begin labelX restX

-- fmap f empty = empty
= Begin (f x) (empty <|> empty)

-- empty <|> empty = empty
= Begin (f x) empty

-- Definition of `pure`, in reverse
--
-- pure label = Begin label empty
= pure (f x)

The fourth Applicative law requires that:

u <*> pure y = pure ($ y) <*> u

Proof:

u <*> pure y

-- Define:
--
-- u = Begin labelU0 (Choice us)
= Begin labelU0 (Choice us) <*> pure y

-- Definition of `pure`
--
-- pure label = Begin label empty
= Begin labelU0 (Choice us) <*> Begin y empty

-- Definition of `(<*>)`
= Begin (labelU0 y) (Choice (fmap adaptU us <|> fmap adaptY empty)
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUY restUY
      where
        Yield labelUY restUY = Begin labelU restU <*> Begin y empty

    adaptY (Done result) = Done result
    adaptY (Yield labelY restY) = Yield labelUY restUY
      where
        Yield labelUY restUY = Begin labelU0 (Choice us) <*> Begin labelY restY

-- fmap f empty = empty
= Begin (labelU0 y) (Choice (fmap adaptU us))
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUY restUY
      where
        Yield labelUY restUY = Begin labelU restU <*> Begin y empty

-- Definition of `pure`, in reverse
--
-- pure label = Begin label empty
= Begin (labelU0 y) (Choice (fmap adaptU us))
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUY restUY
      where
        Yield labelUY restUY = Begin labelU restU <*> pure y

-- Induction: u <*> pure y = pure ($ y) <*> u
= Begin (labelU0 y) (Choice (fmap adaptU us))
  where
    adaptU (Done result) = Done result
    adaptU (Yield labelU restU) = Yield labelUY restUY
      where
        Yield labelUY restUY = pure ($ y) <*> Begin labelU restU

-- Definition of `(<*>)`, in reverse
= Begin ($ y) empty <*> Begin labelU0 (Choice us)

-- Definition of `pure`, in reverse
= pure ($ y) <*> Begin labelU0 (Choice us)

-- Definition of `u`, in reverse:
--
-- u = Begin labelU0 (Choice us)
= pure ($ y) <*> u

No comments:

Post a Comment