{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module TypedProtocolPipelining where
import Prelude hiding (last)
import Data.Function ((&))
import Data.Kind (Type)
import Data.Void
The typed-protocols is a framework for writing binary session types in Haskell. It has been developed by IOHK in collaboration with Well-Typed.
For network applications it is common to use some form of latency hiding for performance reasons. Network is utilised best when constant pressure is applied to avoid shrinking of the tcp window (e.g. tcp flow control mechanism). Network utilisation is a balance between keeping the most constrained resource busy - but only just - too busy and delay increases and application responsiveness can drop. For these reasons, the typed-protocol package allows to express protocol pipelining. In addition, protocol pipelining should in principle allow to make less context switches and improve data locality.
In this blog post we will study pipelining starting with a simple ping pong protocol:
Each arrow designates a message send, the colour of a state signifies its agency, e.g. who is responsible for sending the message. For example MsgPing
is send by the client (green), it also shifts agency from client to server: in the StBusy
state the server holds agency and thus is responsible for sending messages. Not all messages need to transfer agency, we will consider such an extension to the PingPong
protocol later.
The typed-protocols package restricts the way an application executing a protocol can be build and makes it correct by construction. Using type-level programming, one can only construct applications which obey state machine rules faithfully represented by types. A detailed exposition of the package where given at Haskell-eXchange by Duncan Coutts, or my longer workshop at Monadic Party: part 1, part 2, part 3. For example one might construct a client which explores the following state changes:
The client will send MsgPing
and await for MsgPong
before sending next MsgPing
. If we’d like to pipeline all the MsgPing
the communication would look like:
where now we don’t wait for a response before sending next request.
The most important difference between these two diagrams is that the pipelined version is no longer a continuous flow. Pipelining breaks the composition of transitions. Instead, we promise to do some of the transitions at a later time. This delayed processing needs to be managed by the protocol execution environment. What is worth noting that we must keep the order of transitions. In the ping pong protocol this is not readily visible in types as we only collect MsgPong
messages, but one could easily imagine a more complex protocol in which it would matter. It is not difficult to envision that queues enter the picture as we need the first-in first-out semantics.
Our current implementation of pipelining in typed-protocols, which in simplified form we will reconstruct for the purpose of this blog post, is using a pair of threads communicating through a pair of queues. The mix of concurrency and type level programming was a neat idea by Duncan Coutts.
In this post we will explore how to re-implement pipelining which does not involve branching and instead use type level programming to give a non-branching recursive api for pipelining, which can be interpreted without the need of concurrency. As we will see, this will improve the way pipelined protocols can be expressed, at the expense of using additional advanced type level programming machinery (since typed-protocols already rely on similar techniques this is not a concern here).
This is our first simplest attempt to encode a non-pipelined ping-pong client. The client can be in either of the three states:
data PingPong where
StIdle :: PingPong
StBusy :: PingPong
StDone :: PingPong
It can send either of the messages:
data MessageSimplePingPong (st :: PingPong) (st' :: PingPong) where
MsgSimplePing :: MessageSimplePingPong StIdle StBusy
MsgSimplePong :: MessageSimplePingPong StBusy StIdle
MsgSimpleDone :: MessageSimplePingPong StIdle StDone
Now a client can be encoded as a recursive data type (although this representation is not very useful as it does not allow to do any IO):
data SimplePingPongClient (st :: PingPong) a where
SendMsg :: MessageSimplePingPong StIdle st
-> (SimplePingPongClient st a)
-> SimplePingPongClient StIdle a
RecvMsg :: (MessageSimplePingPong StBusy StIdle
-> (SimplePingPongClient StIdle a))
-> SimplePingPongClient StBusy a
ClientDone :: a
-> SimplePingPongClient StDone a
Our initial example client which sends a ping message, awaits for the response, loops it two more times and sends the terminating message can be written as:
simplePingPongClient :: a -> SimplePingPongClient StIdle a
=
simplePingPongClient a SendMsg MsgSimplePing
$ RecvMsg $ \MsgSimplePong ->
SendMsg MsgSimplePing
$ RecvMsg $ \MsgSimplePong ->
SendMsg MsgSimplePing
$ RecvMsg $ \MsgSimplePong ->
SendMsg MsgSimpleDone
$ ClientDone a
The SimplePingPongClient
does not allow us to write a client which pipelines messages.
The idea is that we can separate the sender side from the receiver. Together with a pipelined message we need to present a receiver and a continuation which can send more messages. On the type level we only need to track the number of outstanding pipelined messages. For this we use an inductive natural numbers:
-- | Type level inductive natural numbers.
--
data N = Z | S N
data SimplePipelinedPingPongClient (st :: PingPong) (n :: N) c a where
-- | Pipeline a single message, together with a receiver and a continuation
-- with incremented outstanding message counter.
--
PipelinedSendMsg :: MessageSimplePingPong StIdle st
-> PingPongReceiver StBusy StIdle c
-> SimplePipelinedPingPongClient StIdle (S n) c a
-> SimplePipelinedPingPongClient StIdle n c a
-- | Collect the receiver result. The continuation subtracts from
-- outstanding pipelined message counter.
--
CollectResponse :: (c -> SimplePipelinedPingPongClient StIdle n c a)
-> SimplePipelinedPingPongClient StIdle (S n) c a
-- | Send terminal message; it is only allowed once we collected all the
-- responses.
--
SendMsgDone :: MessageSimplePingPong StIdle StDone
-> SimplePipelinedPingPongClient StDone Z c a
-> SimplePipelinedPingPongClient StIdle Z c a
-- | Once terminating message was sent, return.
--
PipelinedDone :: a
-> SimplePipelinedPingPongClient StDone Z c a
-- | Receiver; callback which is called on each 'MsgPong' received.
--
data PingPongReceiver (st :: PingPong) (st' :: PingPong) c where
RecvPipelinedMsg :: (MessageSimplePingPong StBusy StIdle -> c)
-> PingPongReceiver StBusy StIdle c
-- | Pipelined ping pong client, which for simplicity pipelines two messages
--
simplePipelinedPingPongClient :: a -- ^ fixed result, for simplicity
-> c -- ^ fixed collected value, for simplicity
-> SimplePipelinedPingPongClient StIdle Z c a
=
simplePipelinedPingPongClient a c PipelinedSendMsg
MsgSimplePing
RecvPipelinedMsg $ \MsgSimplePong -> c)
(PipelinedSendMsg MsgSimplePing
(RecvPipelinedMsg $ \MsgSimplePong -> c)
(CollectResponse $ \_c0 ->
(CollectResponse $ \_c1 ->
SendMsgDone MsgSimpleDone $
PipelinedDone a
) )
This is a simplified version of pipelining api implemented in typed-protocols. There are a few minor problems with this approach:
SimplePingPongClient
is brokenc
between all the possibly different pipelining scenariosThe SimplePipelinedPingPongClient
still needs an interpreter. Let’s try to envision how it could look like. In the network context we can consider that we are given a bidirectional bearer with guaranteed ordered delivery of messages. Let’s envision its interface as:
data PingPongChannel m = PingPongChannel {
sendMsg :: forall st st'. MessageSimplePingPong st st' -> m (),
readMsg :: forall st st'. m (MessageSimplePingPong st st')
}
For the real implementation look here.
The SimplePipeliendPingPongClient
interpreter should be a function of this type
runPingPongClient :: PingPongChannel m
-> SimplePipelinedPingPongClient st n c a
-> m a
= undefined runPingPongClient _channel _client
The question is how could we deal with PipelinedSendMsg
which branches between receiver and a continuation? The solution in typed-protocols is to run two threads and communicate between them with a pair of queues. Once we need to interpret PipelinedSendMsg
we would push the receiver to the queue, send a message through the PingPongChannel
and continue. There would be another thread that would read that queue and interpret the receiver with:
runPingPongReceiver :: PingPongChannel m
-> PingPongReceiver st st' c
-> m c
= undefined runPingPongReceiver _channel _receiver
It reads from the network, execute the receiver’s callback and write the result (of type c
) to the other queue, from which it would be available to runPingPongClient
when interpreting CollectResponse
(ref. runPipelinedPeerWithDriver).
So far we tried to present a single client in a type safe way. In general we’d like to be able to represent a wide class of binary protocols, and for each protocol to be able to construct both sides: client and/or server. The following Protocol type class together with auxiliary types PeerRole
and PeerHasAgency
defines what is needed to construct a protocol and proofs of its correctness. So far we’ve only used Message
type from this type class. Each protocol has to define which side has the agency at each state and which states are terminating; for this the type class has to provide ClientHasAgency
, ServerHasAgency
and NobodyHasAgency
together with some lemmas that ensure correctness of the provided associated data instances.
class Protocol ps where
-- | The messages for this protocol. It is expected to be a GADT that is
-- indexed by the @from@ and @to@ protocol states. That is the protocol state
-- the message transitions from, and the protocol state it transitions into.
-- These are the edges of the protocol state transition system.
--
data Message ps (st :: ps) (st' :: ps)
-- | Tokens for those protocol states in which the client has agency.
--
data ClientHasAgency (st :: ps)
-- | Tokens for those protocol states in which the server has agency.
--
data ServerHasAgency (st :: ps)
-- | Tokens for terminal protocol states in which neither the client nor
-- server has agency.
--
data NobodyHasAgency (st :: ps)
-- | If the client has agency for a state, there are no
-- cases in which the server has agency for the same state.
--
exclusionLemma_ClientAndServerHaveAgency :: forall (st :: ps).
ClientHasAgency st
-> ServerHasAgency st
-> Void
-- | If nobody has agency for a state (the state is terminating), there
-- are no cases in which the client has agency for the same state.
--
exclusionLemma_NobodyAndClientHaveAgency :: forall (st :: ps).
NobodyHasAgency st
-> ClientHasAgency st
-> Void
-- | If nobody has agency for a state (the state is terminating), there
-- are no cases in which the server has agency for the same state.
--
exclusionLemma_NobodyAndServerHaveAgency :: forall (st :: ps).
NobodyHasAgency st
-> ServerHasAgency st
-> Void
data PeerRole = AsClient | AsServer
type PeerHasAgency :: PeerRole -> ps -> Type
data PeerHasAgency pr st where
ClientAgency :: !(ClientHasAgency st) -> PeerHasAgency AsClient st
ServerAgency :: !(ServerHasAgency st) -> PeerHasAgency AsServer st
type WeHaveAgency (pr :: PeerRole) st = PeerHasAgency pr st
type TheyHaveAgency (pr :: PeerRole) st = PeerHasAgency (FlipAgency pr) st
type family FlipAgency (pr :: PeerRole) where
FlipAgency AsClient = AsServer
FlipAgency AsServer = AsClient
We already seen that pipelining requires a queue that allows to send more messages before waiting for the replies. But it does not necessarily needs to be a term level queue, equally well we could push the expected transitions on a type level queue, and give a way to collect responses and thus eliminate from the type level queue.
Queue
kindFirst let us define elements that will be pushed on to the queue. When we just send some Message pt from to
and we want to pipeline next message Message from' to'
, we will push Tr to from'
onto the queue. The Tr to from' :: Trans ps
is a promoted type which allows us to track delayed transitions.
data Trans ps where
Tr :: forall ps. ps -> ps -> Trans ps
We represent the type level queue with type level list. <|
and Empty
are simply type aliases, we also provide a snoc operator |>
which we will use to push elements onto the queue.
-- | Queue kind
--
data Queue ps where
Empty :: Queue ps
Cons :: Trans ps -> Queue ps -> Queue ps
-- | Cons type alias
--
type (<|) :: Trans ps -> Queue ps -> Queue ps
type a <| as = Cons a as
infixr 5 <|
-- | Snoc operator
--
type (|>) :: Queue ps -> Trans ps -> Queue ps
type family as |> b where
Empty |> b = Cons b Empty
<| as) |> b = a <| (as |> b)
(a infixr 5 |>
Peer
The PeerPiplined
type is a general API for building protocol applications which satisfy the Protocol
type class constraint. Unlike our previous examples it can be used to build either client or server roles. The client and server build with it are necessarily dual to each other, see theorem_duality
below. It also supports any monad and can embed any monadic computations.
-- | Promoted data type which indicates if 'Peer' is used in
-- pipelined mode or not.
--
data Pipelined = NonPipelined | Pipelined
type Peer :: forall ps
-> PeerRole
-> Pipelined
-> Queue ps
-> ps
-> (Type -> Type)
-> Type
-> Type
data Peer ps pr pl q st m a where
-- | 'Effect' allows to introduce monadic effects.
--
Effect
:: m (Peer ps pr pl q st m a)
-> Peer ps pr pl q st m a
-- | Non-pipelined send. One needs to present proof of agency, message
-- to be send and a continuation. One cannot send
-- non-pipelined messages when there are outstanding requests. This is
-- enforced by requiring that the queue is empty.
--
Yield
:: !(WeHaveAgency pr st)
-> Message ps st st'
-> Peer ps pr pl Empty st' m a
-> Peer ps pr pl Empty st m a
-- | Await for a non-pipelined message. One has to present a proof that
-- one does not have agency and a continuation function which can deal
-- with any messege that might arrive from the network.
--
Await
:: !(TheyHaveAgency pr st)
-> (forall st'. Message ps st st'
-> Peer ps pr pl Empty st' m a)
-> Peer ps pr pl Empty st m a
-- | Terminate the protocol.
--
Done
:: !(NobodyHasAgency st)
-> a
-> Peer ps pr pl Empty st m a
--
-- Pipelining primitives
--
-- | Pipelined send which. Note that the continuation decides from which
-- state we pipeline next message, and the gap is pushed at the back of
-- the queue.
--
YieldPipelined
:: !(WeHaveAgency pr st)
-> Message ps st st'
-> Peer ps pr 'Pipelined (q |> Tr st' st'') st'' m a
-> Peer ps pr 'Pipelined q st m a
-- | Partially collect promissed transtion.
--
Collect
:: Maybe (Peer ps pr 'Pipelined (Tr st' st'' <| q) st m a)
-> !(TheyHaveAgency pr st')
-> (forall stNext. Message ps st' stNext
-> Peer ps pr 'Pipelined (Tr stNext st'' <| q) st m a)
-> Peer ps pr 'Pipelined (Tr st' st'' <| q) st m a
-- | Collect the identitty transition.
--
-- 'CollectDone' allows to defer popping @Tr ps st st@ from the queue
-- after a message is received (in 'Collect' callback), unlike 'Collect'
-- which needs to know the transition type at compile time.
--
CollectDone
:: Peer ps pr 'Pipelined q st m a
-> Peer ps pr 'Pipelined (Tr st st <| q) st m a
PingPong
protocolIn this section we will formalise the ping pong protocol by providing Protocol
instance.
instance Protocol PingPong where
-- | Ping pong messages
--
data Message PingPong from to where
MsgPing :: Message PingPong StIdle StBusy
MsgPong :: Message PingPong StBusy StIdle
MsgDone :: Message PingPong StIdle StDone
data ClientHasAgency st where
TokIdle :: ClientHasAgency StIdle
data ServerHasAgency st where
TokBusy :: ServerHasAgency StBusy
data NobodyHasAgency st where
TokDone :: NobodyHasAgency StDone
-- exclusion lemmas, which prove that n each state at most one of server, or
-- client has agency.
TokIdle tok = case tok of {}
exclusionLemma_ClientAndServerHaveAgency TokDone tok = case tok of {}
exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} exclusionLemma_NobodyAndServerHaveAgency
Some auxiliary instances:
deriving instance Show (Message PingPong from to)
deriving instance Show (ClientHasAgency (st :: PingPong))
deriving instance Show (ServerHasAgency (st :: PingPong))
-- A non-pipelined PingPong.
--
pingPongClient :: a -> Peer PingPong AsClient NonPipelined Empty StIdle m a
=
pingPongClient a -- send ping message
Yield (ClientAgency TokIdle) MsgPing
-- await for the response
$ await
$ Yield (ClientAgency TokIdle) MsgPing
$ await
$ -- send terminating message
Yield (ClientAgency TokIdle) MsgDone
-- return
$ Done TokDone a
where
-- await for all 'MsgPong' until first 'MsgPongDone'
await :: Peer PingPong AsClient NonPipelined Empty StIdle m a
-> Peer PingPong AsClient NonPipelined Empty StBusy m a
=
await k Await (ServerAgency TokBusy) $ \msg ->
case msg of
MsgPong -> k
-- A pipelined 'PingPong', without partial collects.
--
pingPongClientPipelined :: a -> Peer PingPong AsClient 'Pipelined Empty StIdle m a
=
pingPongClientPipelined a -- pipeline three pings
YieldPipelined (ClientAgency TokIdle) MsgPing
$ YieldPipelined (ClientAgency TokIdle) MsgPing
$ YieldPipelined (ClientAgency TokIdle) MsgPing
-- collect three pongs
$ collect
$ collect
$ collect
$ Yield (ClientAgency TokIdle) MsgDone
-- return from the protocol
$ Done TokDone a
where
collect :: Peer PingPong AsClient 'Pipelined q StIdle m a
-> Peer PingPong AsClient 'Pipelined
Tr StBusy StIdle <| q) StIdle m a
(=
collect k Collect Nothing (ServerAgency TokBusy)
$ \msg -> case msg of
MsgPong -> CollectDone k
PingPong2
protocolLet us consider a variation of the ping pong protocol, in which the server might send multiple MsgBusy
before transferring agency back to the client with MsgPong
. In this version by pipelining MsgPing
, we might need to collect multiple MsgBusy
until we receive MsgPong
. It will help us demonstrate that we can pipeline multiple MsgPing
messages and collect all the replies.
-- | PingPong2 has the same state machine, although we will a different
-- `Protocol` instance. For that reason we provide a newtype wrapper and
-- use type aliases.
--
newtype PingPong2 = Wrap PingPong
type StIdle2 = Wrap StIdle
type StBusy2 = Wrap StBusy
type StDone2 = Wrap StDone
instance Protocol PingPong2 where
data Message PingPong2 from to where
-- | 'PingPong' message
MsgPingPong :: Message PingPong st st'
-> Message PingPong2 (Wrap st) (Wrap st')
-- | new message
MsgBusy :: Message PingPong2 (Wrap StBusy) (Wrap StBusy)
data ClientHasAgency st where
WrapClient :: ClientHasAgency st
-> ClientHasAgency (Wrap st)
data ServerHasAgency st where
WrapServer :: ServerHasAgency st
-> ServerHasAgency (Wrap st)
data NobodyHasAgency st where
WrapDone :: NobodyHasAgency st
-> NobodyHasAgency (Wrap st)
-- We haven't changed the states and their agencies, so we can reuse
-- 'PingPong' lemmas.
WrapClient tok) (WrapServer tok') =
exclusionLemma_ClientAndServerHaveAgency (
exclusionLemma_ClientAndServerHaveAgency tok tok'WrapDone tok) (WrapClient tok') =
exclusionLemma_NobodyAndClientHaveAgency (
exclusionLemma_NobodyAndClientHaveAgency tok tok'WrapDone tok) (WrapServer tok') =
exclusionLemma_NobodyAndServerHaveAgency ( exclusionLemma_NobodyAndServerHaveAgency tok tok'
Some auxiliary instances:
deriving instance Show (Message PingPong2 from to)
deriving instance Show (ClientHasAgency (st :: PingPong2))
deriving instance Show (ServerHasAgency (st :: PingPong2))
Collect
-- | A pipelined 'PingPong' which supports partial collects using the
-- recursive 'collect'.
--
pingPongClientPipelined2 :: a
-> Peer PingPong2 AsClient 'Pipelined Empty StIdle2 m a
=
pingPongClientPipelined2 a -- pipeline three 'MsgPing'
YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
$ YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
$ YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
-- collect responses
$ collect
$ collect
$ collect
$ Yield (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgDone)
$ Done (WrapDone TokDone) a
where
-- recursively collect responses, until 'MsgPongDone2' is received
collect :: Peer PingPong2 AsClient 'Pipelined q StIdle2 m a
-- ^ continuation after removing @Tr StBusy2 StIdle2@ from the
-- queue
-> Peer PingPong2 AsClient 'Pipelined
Tr StBusy2 StIdle2 <| q) StIdle2 m a
(=
collect k Collect Nothing (ServerAgency (WrapServer TokBusy))
$ \msg -> case msg of
MsgBusy -> collect k
MsgPingPong MsgPong) -> CollectDone k (
Next example is similar to the previous one but it counts the number of MsgBusy
received.
pingPongClientPipelined2Counter :: Peer PingPong2 AsClient 'Pipelined Empty StIdle2 m Int
=
pingPongClientPipelined2Counter -- pipeline three 'MsgPing2'
YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
$ YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
$ YieldPipelined (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgPing)
-- collect responses, and count received 'MsgBusy'
$ collect 0
$ \n1 -> collect n1
$ \n2 -> collect n2
$ \n3 -> Yield (ClientAgency (WrapClient TokIdle)) (MsgPingPong MsgDone)
$ Done (WrapDone TokDone) n3
where
-- recursively collect responses, until 'MsgPongDone2' is received
collect :: Int
-- ^ number of 'MsgBusy' received so far
-> (Int -> Peer PingPong2 AsClient 'Pipelined q StIdle2 m Int)
-- ^ continuation after removing @Tr StBusy2 StIdle2@ from the
-- queue
-> Peer PingPong2 AsClient 'Pipelined
Tr StBusy2 StIdle2 <| q) StIdle2 m Int
(!n k =
collect Collect Nothing (ServerAgency (WrapServer TokBusy))
$ \msg -> case msg of
MsgBusy -> collect (n+1) k
MsgPingPong MsgPong) -> CollectDone (k n) (
Duality assures that two peers in dual roles: AsClient
vs AsServer
can run a protocol without deadlock. We also prove that if a protocol will terminate both sides will end at a common terminal state (one of the states in which NobodyHasAgency
). The proofs holds under the assumption that the encoding of messages is 1-1, if this assumption is not true it is possible that an application will not terminate when reaching a terminal state, or that it will terminate early causing the other side to deadlock. There are situations when non injective codecs are useful, and these cases require additional care.
First we start with duality for non-pipelined protocols, as this is quite a bit simpler. The code below is copy-paste from typed-protocols package (with small adjustments).
data TerminalStates ps where
TerminalStates :: forall ps (st :: ps) (st' :: ps).
NobodyHasAgency st
-> NobodyHasAgency st'
-> TerminalStates ps
theorem_nonpipelined_duality :: forall ps (pr :: PeerRole) (initSt :: ps) m a b.
Monad m, Protocol ps)
( => Peer ps pr NonPipelined Empty initSt m a
-> Peer ps (FlipAgency pr) NonPipelined Empty initSt m b
-> m (a, b, TerminalStates ps)
= go
theorem_nonpipelined_duality where
go :: forall (st :: ps).
Peer ps pr NonPipelined Empty st m a
-> Peer ps (FlipAgency pr) NonPipelined Empty st m b
-> m (a, b, TerminalStates ps)
Done stA a) (Done stB b) = return (a, b, TerminalStates stA stB)
go (Effect a ) b = a >>= \a' -> go a' b
go (Effect b) = b >>= \b' -> go a b'
go a (Yield _ msg a) (Await _ b) = go a (b msg)
go (Await _ a) (Yield _ msg b) = go (a msg) b
go (
-- By appealing to the proofs about agency for this protocol we can
-- show that these other cases are impossible
Yield (ClientAgency stA) _ _) (Yield (ServerAgency stB) _ _) =
go (
absurd (exclusionLemma_ClientAndServerHaveAgency stA stB)
Yield (ServerAgency stA) _ _) (Yield (ClientAgency stB) _ _) =
go (
absurd (exclusionLemma_ClientAndServerHaveAgency stB stA)
Await (ClientAgency stA) _) (Await (ServerAgency stB) _) =
go (
absurd (exclusionLemma_ClientAndServerHaveAgency stA stB)
Await (ServerAgency stA) _) (Await (ClientAgency stB) _) =
go (
absurd (exclusionLemma_ClientAndServerHaveAgency stB stA)
Done stA _) (Yield (ServerAgency stB) _ _) =
go (
absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB)
Done stA _) (Yield (ClientAgency stB) _ _) =
go (
absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB)
Done stA _) (Await (ServerAgency stB) _) =
go (
absurd (exclusionLemma_NobodyAndServerHaveAgency stA stB)
Done stA _) (Await (ClientAgency stB) _) =
go (
absurd (exclusionLemma_NobodyAndClientHaveAgency stA stB)
Yield (ClientAgency stA) _ _) (Done stB _) =
go (
absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA)
Yield (ServerAgency stA) _ _) (Done stB _) =
go (
absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA)
Await (ClientAgency stA) _) (Done stB _) =
go (
absurd (exclusionLemma_NobodyAndClientHaveAgency stB stA)
Await (ServerAgency stA) _) (Done stB _) =
go ( absurd (exclusionLemma_NobodyAndServerHaveAgency stB stA)
We can show that any peer that is using pipelining primitives can be transformed into non-pipelined version. This is possible because pipelining does not changes the order of messages sent or received. We just need to track this order with PrQueue
. First we define various singletons needed to track the evolution of types.
-- | Singletons for types of kind `Trans`.
--
type STrans :: Trans ps -> Type
data STrans tr where
STr :: STrans (Tr st st')
-- | Singleton for types of kind `Queue` kind.
---
type SQueue :: Queue ps -> Type
data SQueue q where
SEmpty :: SQueue Empty
SCons :: STrans (Tr st st') -> SQueue q -> SQueue (Tr st st' <| queue)
-- | `PrQueue` tracks the order of transitions. We either have an
-- explicit `Message` or a `STrans` singleton, both are pushed by
-- `YieldPipelined` operation.
--
-- Note: if not the order of arguments 'PrQueue' could be given a category
-- instance
type PrQueue :: forall ps -> PeerRole -> ps -> Queue ps -> ps -> Type
data PrQueue ps pr st q st' where
ConsMsgQ :: WeHaveAgency pr st
-> Message ps st st'
-> PrQueue ps pr st' q st''
-> PrQueue ps pr st q st''
ConsTrQ :: STrans (Tr st st')
-> PrQueue ps pr st' q st''
-> PrQueue ps pr st (Tr st st' <| q) st''
EmptyQ :: PrQueue ps pr st Empty st
-- | Push a `ConsMsgQ` to the back of `PrQueue`.
--
snocMsgQ :: WeHaveAgency pr st'
-> Message ps st' st''
-> PrQueue ps pr st q st'
-> PrQueue ps pr st q st''
ConsMsgQ stok' msg' pq) =
snocMsgQ stok msg (ConsMsgQ stok' msg' (snocMsgQ stok msg pq)
ConsTrQ str pq) =
snocMsgQ stok msg (ConsTrQ str (snocMsgQ stok msg pq)
EmptyQ =
snocMsgQ stok msg ConsMsgQ stok msg EmptyQ
-- | Push a `STrans (Tr st st')` to the back of `PrQueue`.
--
snocTrQ :: STrans (Tr st' st'')
-> PrQueue ps pr st q st'
-> PrQueue ps pr st (q |> Tr st' st'') st''
ConsMsgQ stok msg pq) =
snocTrQ tr (ConsMsgQ stok msg (snocTrQ tr pq)
ConsTrQ tr' pq) =
snocTrQ tr (ConsTrQ tr' (snocTrQ tr pq)
EmptyQ =
snocTrQ tr ConsTrQ tr EmptyQ
-- | Derive `SQueue q` singleton from `PrQueue ps pr st q st'` by
-- a simple traversal.
--
promisedQueue :: PrQueue ps pr st q st' -> SQueue q
ConsMsgQ _ _ pq) = promisedQueue pq
promisedQueue (ConsTrQ tr pq) = SCons tr (promisedQueue pq)
promisedQueue (EmptyQ = SEmpty promisedQueue
With all the singletons at hand we are ready to prove:
theorem_unpipeline :: forall ps (pr :: PeerRole) (pl :: Pipelined) (initSt :: ps) m a.
Functor m
=> [Bool]
-- ^ interleaving choices for pipelining allowed by
-- `Collect` primitive. False values or `[]` give no
-- pipelining.
-> Peer ps (pr :: PeerRole) pl Empty initSt m a
-> Peer ps pr NonPipelined Empty initSt m a
= go cs0 EmptyQ
theorem_unpipeline cs0 where
go :: [Bool]
-> PrQueue ps pr st q st'
-> Peer ps pr pl q st' m a
-> Peer ps pr 'NonPipelined Empty st m a
Effect k) = Effect $ go cs pq <$> k
go cs pq (EmptyQ (Yield stok msg k) = Yield stok msg $ go cs EmptyQ k
go cs EmptyQ (Await stok k) = Await stok $ go cs EmptyQ . k
go cs EmptyQ (Done stok a) = Done stok a
go _
YieldPipelined stok msg k) =
go cs pq (-- push message and promised transition to `PrQueue`.
go cs ( pq& snocMsgQ stok msg
& snocTrQ STr
)
k
ConsMsgQ stok msg pq) k = Yield stok msg $ go cs pq k
go cs (
True:cs') pq (Collect (Just k) _ _) =
go (
go cs' pq kConsTrQ _ pq) (Collect _ stok k) =
go cs (Await stok $ go cs (ConsTrQ STr pq) . k
ConsTrQ _ pq) (CollectDone k) =
go cs ( go cs pq k
The proof of our main theorem is a straight forward consequence of our earlier results:
theorem_duality :: forall ps (pr :: PeerRole) (pl :: Pipelined) (st :: ps) m a b.
Monad m, Protocol ps )
( => [Bool]
-> [Bool]
-> Peer ps pr pl Empty st m a
-> Peer ps (FlipAgency pr) pl Empty st m b
-> m (a, b, TerminalStates ps)
=
theorem_duality csA csB a b
theorem_nonpipelined_duality (theorem_unpipeline csA a) (theorem_unpipeline csB b)
There is available an alternative implementation of typed-protocols in Agda, see here. The Agda implementation has a nicer interface. The Haskell implementation needs to provide Protocol
instance, which requires to define:
ClientHasAgency
, ServerHasAgency
, NobodyHasAgency
.The Agda implementation however makes an explicit distinction between objective agency (ClientAgency
, ServerAgency
, NobodyAgency
) and a relative agency (WeHaveAgency
, TheyHaveAgency
, NobodyHasAgency
), and is indexed over:
The exclusion lemmas are proven for all protocols which are provided with this interface. One still needs to provide agency witnesses for Peer
primitives, but they one only can provide them with propositional equality _≡_
(which is equivalent to Haskell’s :~:
), and hence simpler to use.
The simplification found in Agda implementation is a future possible improvement in typed-protocols.
{-# LANGUAGE ScopedTypeVariables #-}
module Mask where
import Control.Concurrent.MVar
import Control.Exception
import GHC.IO.Handle.Types (Handle__)
The base library explains asynchronous exceptions and masking quite well, but still this is one of the topics that is often misunderstood and some of its crucial parts like interruptible operations are not well enough documented to slip under the radar too often.
There are two main ways of throwing exceptions in Haskell, either with throwIO
or throwTo
. throwIO
throws an exception in the current thread in synchronous way, throwTo
allows to throw an exception in some other thread, hence the name asynchronous exceptions. But let’s start from the beginning, why we even need asynchronous exceptions? This is nicely answered in the paper Asynchronous Exceptions in Haskell:
- Speculative computation. A parent thread might start a child thread to compute some value speculatively; later the parent thread might decide that it does not need the value so it may want to kill the child thread.
- Timeouts: If some computation does not complete within a specified time budget, it should be aborted.
- User interrupt. Interactive systems often need to cancel a computation that has already been started, for example when the user clicks on the “stop” button in a web browser.
- Resource exhaustion. Most Haskell implementations use a stack and heap, both of which are essentially finite resources, so it seems reasonable to inform the program when memory is running out, in order that it can take remedial action. Since such exceptions can occur at almost any program point, it is natural to treat them as asynchronous.
Asynchronous exceptions can interrupt almost any computation, masking is provided as a way to make it predictable, so we can reason about it. Let’s examine this standard example:
withLockUnmasked :: MVar () -> IO a -> IO a
= do
withLockUnmasked lock k
takeMVar lock<- catch k (\(e :: SomeException) -> putMVar lock ()
a >> throwIO e)
putMVar lock () return a
The problem with withLockUnmasked
is that an asynchronous exception could be thrown just after takeMVar
is executed but before the catch
installs the handler. To be able to fix this, Haskell provides primitive operations which allow to mask asynchronous exceptions. Each thread keeps the following masking state (original haddocks preserved):
-- | Describes the behaviour of a thread when an asynchronous
-- exception is received.
data MaskingState
= Unmasked
-- ^ asynchronous exceptions are unmasked (the normal state)
| MaskedInterruptible
-- ^ the state during 'mask': asynchronous exceptions are masked, but
-- blocking operations may still be interrupted
| MaskedUninterruptible
-- ^ the state during 'uninterruptibleMask': asynchronous exceptions are
-- masked, and blocking operations may not be interrupted
Let us stress that in MaskedInterruptible
state, which is a result of using mask
function, asynchronous exceptions can be thrown, but only by interruptible operations. In the MaskedUninterruptible
asynchronous exceptions cannot be thrown even by blocking / interruptible operations. Asynchronous Exceptions in Haskell paper specifies interruptible operations as:
Any operation which may need to wait indefinitely for a resource (e.g.,takeMVar) may receive asynchronous exceptions even within an enclosing mask, but only while the resource is unavailable.Such operations are termed interruptible operations.The complete list of interruptible operations is astonishingly short:
takeMVar
when the MVar
is empty,
putMVar
when the MVar
is non-empty,
retry :: STM a
,
throwTo
IORef
operations,
safe
and unsafe
foreign calls. There is a subtle difference between safe
and unsafe
ffi: when a safe ffi returns haskell thread will check if there are pending asynchronous exceptions while haskell rts does not know about unsafe
ffi calls.
We have two ways of fixing withLockUnamsked
:
withLockMaskedInterruptible :: MVar () -> IO a -> IO a
= mask $ \unmask -> do
withLockMaskedInterruptible lock k
takeMVar lock<- catch (unmask k)
a e :: SomeException) -> putMVar lock ()
(\(>> throwIO e)
putMVar lock () return a
withLockMaskedUninterruptible :: MVar () -> IO a -> IO a
= uninterruptibleMask $ \unmask -> do
withLockMaskedUninterruptible lock k
takeMVar lock<- catch (unmask k)
a e :: SomeException) -> putMVar lock ()
(\(>> throwIO e)
putMVar lock () return a
The difference between both of them is subtle. To get to the point we need to analyse which operations are blocking / interruptible. As specified in Asynchronous Exceptions in Haskell, takeMVar
is blocking only if v :: MVar ()
is empty. We have two cases:
v
is non-empty: neither of the two can raise asynchronous exception while executing takeMVar
. This means that both implementations will install the exception handler before an asynchronous exception is raised, and this is what we wanted.
if v
is empty: the semantics of MVar
ensures that takeMVar
is interruptible until it is empty, once takeMVar
takes the value it becomes non-blocking. This ensure that asynchronous exceptions can be raised by withLockMaskedInterruptible
only when takeMVar
is blocked. This also means that withLockMaskedInterruptible
will install the catch handler once takeMVar
past the point of being interruptible.
The crucial difference between withLockMaskedInterruptible
and withLockMaskedUninterruptible
is that the later will never throw an async exception while takeMVar
is blocked while the lock is empty (e.g. taken by some other thread).
It seem that analysing the code which is using mask
is more difficult than when using uninterruptibleMask
, is it really so? The main problem with withLockMaskedUninterruptible
is that it can potentially introduce deadlocks; a program might become unresponsive: interruptions like one delivered by signals (e.g. CTRL-C
) are delivered using asynchronous exceptions; or it could introduce undeliverable timeouts, which in networking applications can introduce safety hazards. Because deadlocks are non-local properties there is actually no way to analyse if withLockMaskedUninterruptible
is safe or not without its context, it depends on the program where it is used. For this reasons the documentation of uninterruptibleMask
says in capital letters: THIS SHOULD BE USED WITH GREAT CARE. In my experience, debugging asynchronous exceptions is easier than debugging deadlocks. When logging is done right you can see asynchronous exceptions in the logs, but you will not see a bunch of threads being deadlocked.
Takeaways from this are:
takeMVar
is only blocking if the MVar
is empty.Both safe-exceptions and unliftio are using bracket
implementation which is masking using uninterruptibleMask
, while base package is using mask
. Which one is more appropriate in a library?
This is base’s implementation of bracket
:
bracket :: IO a
-> (a -> IO b)
-> (a -> IO c)
-> IO c
=
bracket before after thing $ \restore -> do
mask <- before
a <- restore (thing a) `onException` after a
r <- after a
_ return r
The version used by unliftio and safe-exceptions are both implemented using try
but the crucial difference is that they are using uninterruptibleMask
when executing the after
callback. Since they are using uninterruptibleMask
they need to use try
to avoid blocking exceptions when executing the before
handler. This is to minimize time when a thread is in MaskedUninterruptible
state.
Let us look at the most common resource handlers:
The base package does not export Handle
constructors, they are an implementation detail, so let’s bring the definition here:
data Handle
= FileHandle -- A normal handle to a file
FilePath -- the file (used for error messages
-- only)
!(MVar Handle__)
| DuplexHandle -- A handle to a read/write stream
FilePath -- file for a FIFO, otherwise some
-- descriptive string (used for error
-- messages only)
!(MVar Handle__) -- The read side
!(MVar Handle__)
hClose :: Handle -> IO ()
calls hClose’
which masks exceptions while calling takeMVar
(in withHandle’
), and continues (while exceptions are masked) with hClose_help
, which does a few interesting things:
GHC.IO.Device.close
to close the file descriptor.
Flushing file handle buffer is done by either safe (non-threaded rts) or unsafe (threaded rts) ffi call (using c_write
or c_safe_write
), and thus is uninterruptible. Closing the decoder is either a no-op (return ()
) or an unsafe foreign call to iconv_close
. We are left with analysing GHC.IO.Device.close
. Handle__
is using IODevice
FD
instance. On systems that support either epoll
, poll
or kqueue
(e.g. on Linux
, MacOS
, FreeBSD
, and alikes) it is done via event manager. On other operating systems (Windows
) closing file handle is done by a direct foreign call (this might change in the future with the new mio
Windows event manager based on I/O completion ports). When event manager is involved, the closeFdWith
is used. I recently fixed a bug which made it interruptible, see PR #4942. However, because calls which involve epoll
are very fast all the blocking operations done by closeFdWith
would block for a very short time, making it quite unlikely to be an issue (but if you run a service for long enough it could be observed).
The conclusion is that closing a file handle could only block on the TMVar
holding Handle__
. This makes it non-blocking if file handles are not closed concurrently.
This would mean trying to close a file handle from multiple threads. The question is why one would ever need that? A good pattern for using file handles is withFile. Where the callback is only used to read and parse the content of the file and return the result. This is runs in a synchronous way which makes the bracket
used by withFile
not leak any resources. Another design pattern for using file handles comes from streaming libraries like pipes, streaming or conduit. To ensure that the handle is correctly closed, one needs to use ResourceT from resourcet package. Streaming is synchronous so we are safe when using hClose
.
The network package close
calls (for non-Windows, threaded RTS) closeFdWith
with an uninterruptible FFI function (c_close). Which we already know that is non-blocking.
For non-threaded RTS or on Windows, Network.Socket.close
directly calls the uninterruptle c_close.
When dealing with threads as resources the killThread
is implemented using throwTo
which is an interruptible operation. It blocks until exception is delivered to the target thread. When using killThread
as a resource finaliser we should use uninterruptibleMask_ . killThread
instead (this week I fixed exactly such bug, see). The same applies when using async package which exports uninterruptibleCancel :: Async a -> IO ()
. Let us note that the withAsync
is internally using uninterruptibleMask_
Back to safe-exceptions and unliftio. In my opinion the base has a better choice for bracket
. Debugging deadlocks, is quite hard. GHC has deadlock detection mechanism but it is not always reliable. Both deadlocks and resource leaks can be silent (no logs), but the latter are clearly visible when tracking state of the program with some system tools, or just looking at /proc
directly.
The essential trade-offs between both implementations is which kind of programmer’s errors they allow:
base
implementation allows to use interruptible release resource function, which might not run till its completion in presence of an asynchronous exception;
safe-exception
implementation allows to make the program deadlock (which might even prevent a program from termination when a kill signal is send, e.g. via CTRL-C
).
Another common argument for safe-exceptions is that it allows to avoid to catch asynchronous exceptions by default. Catching SomeException
can indeed lead to trouble, though for that reason it has been recommended to catch exceptions which you care about not all of them. To avoid catching asynchronous exceptions one can always use the following snippet (though it’s still recommended to be more specific than any synchronous exception!):
->
catchJust (\e case fromException e :: Maybe SomeAsyncException of
Just _ -> Nothing
Nothing -> Just e
)
Above all, use your best judgement how to handle exceptions. In some applications using Either
as a return type is the best option for dealing with synchronous exceptions, in some critical applications catching any exceptions at some level (the non-recommended way) is the safest way to avoid triggering bugs which would use rare execution path. There is just not a single way which which suits all applications and it all depends on the security / threat model under which one is operating.
throwTo
rather than a synchronous one as implemented in GHC, the relevant semantic changes are discussed in section 9.
closeFdWith
merge request #4942
In this posts we will explore the equivalence between applicative and monoidal functors (i.e. functors which preserve cartesian product).
module Data.Functor.Monoidal where
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
We will only focus on a basic example of a monoidal category. The prototypical example is category with products, e.g. the category Hask
together with (,)
type, and this is the category we will consider. A monoidal category also assumes a unit object and some laws for the monoidal product which look very familiar to those of a monoid, but slightly more general. A monoidal structure in a given category is a bit like a monoid, where you can combine any two objects of a category but the unitality and associativity laws have to be relaxed. They are satisfied up to an isomorphism. This is needed even in the simplest case as we have here where the monoidal product is simply given by the categorial product, i.e. the pair type (a,b)
.
associativity
assoc :: (a, (b, c)) -> ((a, b), c)
= ((a, b), c) assoc (a, (b, c))
left unit
leftUnit :: a -> ((), a)
= ((), a) leftUnit a
right unit
rightUnit :: a -> (a, ())
= (a, ()) rightUnit a
And these isomorphism have to satisfy additional, so called coherence conditions. This is all done for a greater generality, where one wants the monoidal product to keep reasonable simple. Since we’re not focused here on full introduction of monoidal categories, and we won’t need its coherence laws we will not dive into the details.
There are monoidal categories which monoidal product is different than the product, and this is probably more natural for many application in pure mathematics, especially in algebra (tensor product in linear algebra, smashed product in some topological context, or the category of endofunctors, …).
Since we now have a Hask
as an example of a monoidal category, we will be interested in functors that preserve this monoidal structure. They are called monoidal functors, and they are defined by the following type class.
class Functor f => Monoidal f where
unit :: f ()
(<|>) :: f a -> f b -> f (a, b)
infixl 4 <|>
Note that this definition expressese the notion of a monoidal endo-functors of the category (->)
in which the monoidal product is given by the tuple type (a, b)
.
Monoidal functors have to obey the following laws:
left unit law
<|> fb = (unit,) <$> fb unit
right unit law
<|> unit = (,unit) <$> fa fa
naturality
<$> fa) <|> fb = (\(a,b) -> (f a, b)) <$> (fa <|> fb)
(f <|> (f <$> fb) = (\(a,b) -> (a, f b)) <$> (fa <|> fb) fa
Thus
<|> unit = (unit,) <$> unit = (,unit) <$> unit unit
There’s no need to introduce applicative functors. Let me just cite the applicative functor laws, which we will use quite extensievly:
identity law
pure id <*> v = v
composition law
pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
homomorphism law
pure f <*> pure x = pure (f x)
interchange law
<*> pure y = pure ($ y) <*> u u
We will now present an argument that every applicative functor is a functor for which the following formula holds:
fmap f fa = pure f <*> fa
Lemma If f
is an applicative functor then
liftA :: Applicative f => (a -> b) -> f a -> f b
= pure f <*> fa liftA f fa
satisfies functor laws.
Proof
id fa
liftA = pure id <*> fa
-- by identity law
= fa
. g) fa
liftA (f = pure (f . g) <*> fa
= pure ((.) f g) <*> fa
= pure (.) <*> pure f <*> pure g <*> fa
-- by composition law
= pure f <*> (pure g <*> fa)
= liftA f (liftA g fa)
QED
Any data structure has at most one functor instance, thus whenever one has a functor instance it must be the one. As a consequence for an applicative functor fmap
and liftA
are always equal. This allows us to use liftA
in exchange for fmap
in proofs. That’s very handy, since otherwise the applicative properties do not provide any compatiblity with fmap
.
It turns out that every applicative functor is a monoidal one. And this is thanks to the following standard definition of monoidal
and a bit further down monoidalUnit
:
-- | Every applicative functor is monoidal.
--
monoidal :: Applicative f
=> f a
-> f b
-> f (a, b)
= (,) <$> fa <*> fb monoidal fa fb
monoidalUnit :: Applicative f
=> f ()
= pure () monoidalUnit
instance Monoidal Identity where
= monoidalUnit
unit <|>) = monoidal
(
instance Monoidal IO where
= monoidalUnit
unit <|>) = monoidal (
But we still need to prove the monoidal laws.
Monoidal laws of monoidal
and monoidalUnit
left unit law
`monoidal` fb
monoidalUnit = (,) <$> (pure ()) <*> fb
= pure (,) <*> pure () <*> fb
-- by homomorphism law
= pure ((),) <*> fb
= ((),) <$> fb
right unit law
`monoidal` monoidalUnit
fa = (,) <$> fa <*> pure ()
-- by interchange law
= pure ($ ()) <*> ((,) <$> fa)
= pure ($ ()) <*> (pure (,) <*> fa)
-- by composition law
= pure (.) <*> pure ($ ()) <*> pure (,) <*> pure fa
= pure ((.) ($ ()) (,)) <*> fa
= pure (\(a -> (a, ())) <*> fa
= pure (,()) <*> fa
= (,()) <$> fa
Lemma
-> (f a, b)) <$> fa <*> fb
(\a b = (\(a, b) -> (f a, b)) <$> ((,) <$> fa <$> fb)
Proof It’s probably not a surprise that we will need to use applicative composition law. A first useful observation is that
-> (f a, b))
(\a b = (\g -> (\(a, b) -> (f a, b)) . g) . (\a b -> (a, b))
= ((.) (\(a, b) -> (f a, b))) . (\a b -> (a, b))
-> (f a, b)) <$> fa <*> fb
(\a b -- by the above observation
= (((.) (\(a, b) -> (f a, b))) . (\a b -> (a, b))) <$> fa <*> fb
-- by functor law
= ((.) (\(a, b) -> (f a, b))) <$> ((\a b -> (a, b)) <$> fa) <*> fb
= pure ((.) (\(a, b) -> (f a, b))) <*> ((\a b -> (a, b)) <$> fa) <*> fb
-- by applicative homomorphism law
= pure (.) <*> pure (\(a, b) -> (f a, b)) <*> ((\a b -> (a, b)) <$> fa) <*> fb
-- by applicative composition law
= pure (\(a, b) -> (f a, b)) <*> (((\a b -> (a, b)) <$> fa) <*> fb)
-- by applicative functor lemma
= (\(a, b) -> (f a, b)) <$> ((,) <$> fa <$> fb)
QED
naturality laws
<$> fa) `monoidal` fb
(f = (,) <$> (f <$> fa) <*> fb
= (,) <$> (pure f <*> fa) <*> fb
= pure (,) <*> (pure f <*> fa) <*> fb
-- by composition law
= pure (.) <*> pure (,) <*> pure f <*> fa <*> fb
-- by functor lemma
= pure ((.) (,) f) <*> fa <*> fb
= pure (\a b -> (f a, b)) <*> fa <*> fb
= (\a b -> (f a, b)) <$> fa <*> fb
= (\(a, b) -> (f a, b)) <$> ((\a b -> (a, b)) <$> fa <*> fb)
-- by previous lemma
= (\(a, b) -> (f a, b)) <$> ((,) <$> fa <*> fb)
= (\(a, b) -> (f a, b)) <$> (fa `monoidal` fb)
`monoidal` (f <$> fb)
fa = (,) <$> fa <*> (f <$> fb)
= ((,) <$> fa) <*> (pure f <*> fb)
-- by composition law
= pure (.) <*> ((,) <$> fa) <*> pure f <*> fb
= (.) <$> ((,) <$> fa)) <*> pure f <*> fb
-- by functor law
= (.) . (,) <$> fa <*> pure f <*> fb
-- by interchange law
= pure ($ f) <*> ((.) . (,) <$> fa) <*> fb
= pure ($ f) <*> (pure ((.) . (,)) <*> fa) <*> fb
-- by composition law
= pure (.) <*> pure ($ f) <*> pure ((.) . (,)) <*> fa <*> fb
= pure ((.) ($ f) ((.) . (,))) <*> fa <*> fb
= pure (\(a,b) -> (a, f b)) <*> fa <*> fb
= (\a b -> (a, f b)) <$> fa <*> fb
= (\(a, b) -> (a, f b)) . (,) <$> fa <*> fb)
-- by composition law
= (\(a, b) -> (a, f b)) <$> ((,) <$> fa <*> fb)
-- | And conversely every monoidal functor is applicative.
--
monoidalAp :: Monoidal f
=> f (a -> b)
-> f a
-> f b
=
monoidalAp fab fa uncurry ($) <$> (fab <|> fa)
monoidalPure :: Monoidal f
=> a
-> f a
= unit $> a monoidalPure a
Applicative laws of monoidalAp
and monoidalPure
homomorphism law
`monoidalAp` monoidalPure a
monoidalPure ab = uncurry ($) <$> ((unit $> ab) <|> (unit $> a))
= uncurry ($) <$> ((const ab <$> unit) <|> ((const a <$> unit)))
= uncurry ($) <$> (\_ -> (ab, a)) <$> (unit <|> unit)
= uncurry ($) . (\_ -> (ab, a)) <$> (unit <|> unit)
= const (ab a) <$> (unit <|> unit)
const a) <$> f == (const b) <$> g for any
by the fact that that (`f, g :: f a`
= const (ab a) <$> unit
of ($>)
by definition = unit $> (ab a)
= monoidalPure (ab a)
QED
identity law
id `monoidalAp` f
monoidalPure = uncurry ($) <$> ((unit $> id) <|> f)
/naturality/ (and the definition of @'$>'@
by = uncurry ($) <$> (\(_, b) -> (id, b)) <$> (unit <|> f)
= uncurry ($) . (\(_, b) -> (id, b)) <$> (unit <|> f)
= (\(_, b) -> b) <$> (unit <|> f)
/right unit/ law
by = (\(_, b) -> b) <$> ((),) <$> f
= (\(_, b) -> b) . ((),) <$> f
= id <$> f
= f
QED
interchange law, i.e. u <*> pure y = pure ($ y) <*> u
`monoidalAp` (monoidalPure y)
u = uncurry ($) <$> (u <|> (unit $> y))
= uncurry ($) <$> (\(x, ) -> (x, y)) <$> (u <|> unit)
= uncurry ($) . (\(x, _) -> (x, y)) <$> (u <|> unit)
= (\(x, _) -> x y) <$> (u <|> unit)
= (\(x, _) -> x y) <$> (,()) <$> u
= (\(x, _) -> x y) . (,()) <$> u
= (\(x, _) -> x y) . (,()) <$> (\(_, x) -> x) <$> (unit <|> u)
= (\(x, _) -> x y) . (,()) . (\(_, x) -> x) <$> (unit <|> u)
= (\(_, x) -> x y) <$> (unit <|> u)
= uncurry ($) . (\(_, x) -> ($ y, x)) <$> (unit <|> u)
= uncurry ($) <$> (\(_, x) -> ($ y, x)) <$> (unit <|> u)
= uncurry ($) <$> ((unit $> ($ y)) <|> u)
= uncurry ($) <$> ((monoidalPure ($ y)) <|> u))
= (monoidalPure ($ y)) `monoidalAp` u
QED
composition law i.e. pure (.) <*> u <*> v <*> w = u <*> (v <*> w)
.) `monoidalAp` u `monoidalAp` v `monoidalAp` w
monoidalPure (= (uncurry ($) <$> ((unit $> (.)) <|> u)) `monoidalAp` v `monoidalAp` w
= uncurry ($)
<$> ((uncurry ($)
<$> ((unit $> (.)) <|> u)) <|> v)
`monoidalAp` w
= uncurry ($)
<$> (\((x,y),z) -> (x y, z))
<$> ((unit $> (.)) <|> u <|> v)
`monoidalAp` w
= uncurry ($) . (\((x,y),z) -> (x y, z))
<$> ((unit $> (.)) <|> u <|> v)
`monoidalAp` w
= (\((x,y),z) -> x y z)
<$> ((unit $> (.)) <|> u <|> v)
`monoidalAp` w
= (\(x,y) -> x . y)
<$> (u <|> v)
`monoidalAp` w
= uncurry (.) <$> (u <|> v) `monoidalAp w
= uncurry ($)
<$> (uncurry (.) <$> (u <|> v)) <|> w
= uncurry ($) . (\((x,y),z) -> (x . y, z))
<$> (u <|> v <|> w)
= (\((x,y),z) -> x . y $ z)
<$> (u <|> v <|> w)
= (\((x,y),z) -> x (y z))
<$> (u <|> v <|> w)
= uncurry (.)
<$> (u <|> v <|> w)
And from the other side:
`monoidalAp` (v `monoidalAp` w)
u = uncurry ($) <$> (u <|> (v `monoidalAp` w))
= uncurry ($) <$> (u <|> (uncurry ($) <$> (u <|> w)))
= uncurry ($) <$> (\((x,y) -> (x, uncurry ($) y)))
<$> (u <|> (u <|> w))
= uncurry ($) . (\((x,y) -> (x, uncurry ($) y))
<$> (u <|> (v <|> w))
= (\((x, y) -> x (uncurry ($) y)))
<$> (u <|> (v <|> w))
= (\(x, (y, z) -> x (y z))
<$> (u <|> (v <|> w))
= (\(x, (y, z) -> x (y z)) . (\((x,y),z) -> (x,(y,z)))
<$> (u <|> v <|> w)
= (\((x,y),z) -> x (y z))
<$> (u <|> v <|> w)
= uncurry (.)
<$> (u <|> v <|> w)
QED
In this section we consider an applicative functor f
and we consider tha applicative monoidalAp
and monoidalUnit
obtained from the associated monoidal functor. We show that these are equal to what we start with <*>
and pure
of f
.
The strategy of the proof transform all <$>
into <*>
using f <$> x = pure f <*> x
and mobe all brackets to the left using the composition law of applicative functors.
When we’ll get to the above canonical form (brackets grouped to the left) this will be all based on:
Lemma 1
.) (uncurry ($)) . (,) = ($) (
Proof
.) (uncurry ($)) . (,)) f a =
((of (.)
by definition = (\x -> (.) (uncurry ($)) (x,)) f a
= (\x -> (uncurry ($)) . (x,)) f a
of (.)
by definiiton = (\x y -> (uncurry ($)) (x, y)) f a
by eta reduction= uncurry ($) (f, a)
= ($) f a
= f a
QED
Below we show that if we take monoidalAp
defined via <|>
which is defined by monoidalAp
(which we denote by <*>
to make all the expressions shorter), then we will recover our original applicative <*>
(e.g. monoidalAp
):
monoidalAp fab fa-- by definition of `monoidalAp`
= uncurry ($) <$> (fab <|> fa)
-- by defintion of `<|>`
= uncurry ($) <$> ((,) <$> fab <*> fa)
= uncurry ($) <$> (pure (,) <*> fab <*> fa)
= pure (uncurry ($)) <*> ((pure (,) <*> fab) <*> fa)
by composition= pure (.) <*> pure (uncurry ($)) <*> (pure (,) <*> fab) <*> fa
= pure ((.) (uncurry ($))) <*> (pure (,) <*> fab) <*> fa
2
by lemma = fab <*> fb
Lemma 2
pure ((.) (uncurry ($))) <*> (pure (,) <*> fab) = fab
Proof
pure ((.) (uncurry ($))) <*> (pure (,) <*> fab)
/composition law/ of applicative functors
by = pure (.) <*> pure ((.) (uncurry ($))) <*> pure (,) <*> fab
= pure ((.) ((.) (uncurry ($)))) <*> pure (,) <*> fab
= pure ((.) ((.) (uncurry ($))) (,)) <*> fab
= pure (((.) (uncurry ($))) . (,)) <*> ab
1
by lemma = pure ($) <*> fab
$) = (id :: (a -> b) -> (a -> b)
since (and (pure id) <*> x = x
= fab
QED
In this section we consider a monoidal functor f
, and then we consisder tha monoidal functor obtained from the associated applicative functor by means of monoidalAp
and monoidalUnit
. We prove that what we end with is the initial monoidal functor f
. We use <|>
and unit
to denote the initial monoidal structer of f
, <*>
and pure
is the associated applicative instance, and we will show that monoidal
is equal to <|>
monoidal fa fb= (,) <$> fa <*> fb
= ((,) <$> fa) <|> fb)
= uncurry ($) <$> ((,) <$> fa) <|> fb
= uncurry ($) <$> (fmap (\(a, b) -> ((a,),b)) <$> (fa <|> fb))
= uncurry ($) . (\(a, b) -> ((a,),b) <$> (fa <|> fb)
= id <$> (fa <|> fb)
= fa <|> fb
monoidalUnit= pure ()
-- by definition of pure for the associated applicative functor
= monoidalPure ()
= unit $> ()
= unit
Applicative Programming with Effects, Conor McBride and Ross Peterson, Journal of Functional Programming, 2008.
There is a final section which briefly mentions equivalnce between strict lax monoidal functors and applicative ones (without all the details we went through here). It touches some subtle difference between categorical formulation and a higher order functional perspective (also used here), which are byond this blog post.
Have you every wondered why monads turn out to be the abstraction behind IO
? To find an answer we will build a two (very incomplete) models for IO
:
IO
actions{-# LANGUAGE GADTs #-}
module MonadicIO where
import Control.Monad (ap)
import qualified System.IO as IO
data IOAction x
= Write FilePath String
| Read FilePath
| Return x
Mostly found in imperative languages, where IO is a sequence of operations. And where Return
has the semantics of a final statement. There are many algebras that provide a sequences. The most general one we could pick are non associative semigroups (also called magmas). It would have two problems:
For that reasons, we will use associative unital magmas, e.g. a monoid. The good choice should be the most general such object, i.e. a free monoid
type MonoidalIO x = [IOAction x]
For a side note: DList
is a free monoid, while []
is free in the class of left strict monoids, e.g. monoids satisfying: undefined <> == undefined
, but let’s not focus on these differences here …
Let us provide a way to actually run MonoidalIO
, since we are in Haskell let us interpret MonoidalIO
in the IO
monad.
runMonoidalIO :: MonoidalIO x -> IO x
Return x : _) = return x
runMonoidalIO (Write path str) : next) =
runMonoidalIO ((IO.writeFile path str >> runMonoidalIO next
Read path) : next) =
runMonoidalIO ((IO.readFile path >> runMonoidalIO next
= error "error: no action" runMonoidalIO []
There is yet another way of organising a sequence of computations. And it is especially compelling in a language with algebraic data types.
In a recursive style we can describe the whole program progression using a single recursive data structure, where each computation carries a continuation.
data MonadicIO x
= WriteM FilePath String (MonadicIO x)
| ReadM FilePath (String -> MonadicIO x)
| ReturnM x
instance Functor MonadicIO where
fmap f (ReturnM x) = ReturnM (f x)
fmap f (ReadM path io) = ReadM path ((fmap . fmap) f io)
fmap f (WriteM path str io) = WriteM path str (fmap f io)
We can transform any MonoidalIO
into MonadicIO
.
-- | transform `MonoidalIO` into `MonadicIO`
--
fromMonoidalIO :: MonoidalIO x -> MonadicIO x
Read path) : next) = ReadM path (\_ -> fromMonoidalIO next)
fromMonoidalIO ((Write path str) : next) = WriteM path str (fromMonoidalIO next)
fromMonoidalIO ((Return x : _) = ReturnM x
fromMonoidalIO (= error "error: no action" fromMonoidalIO []
We cannot transform MonadicIO
to MonoidalIO
, only because we did not provide a way to bind data read from a file in MonoidalIO
just for simplicity of the presentation. But the two approaches should be equivalent.
We also need a way to run MonadicIO
, again since we are in Haskell we’ll provide a map to IO
:
runMonadicIO :: MonadicIO x -> IO x
ReturnM x) = return x
runMonadicIO (ReadM path io) = IO.readFile path >>= runMonadicIO . io
runMonadicIO (WriteM path str io) = IO.writeFile path str >> runMonadicIO io runMonadicIO (
But this allows only to run expressions of type MonadicIO x
, we still need a way to run expressions of type MonadicIO (MonadicIO (... x))
. This proves that the MonadicIO
can be run (if we’d end up with a functor that would not have a natural transformation to Haskell’s IO
we’d be in troubles)
In MonoidalIO
we relied on associativity of the list concatenation, a similar requirements is needed here. We want that the end result is independent of how it was build using >>=
or equivalently how we join
a value of type MonadicIO (MonadicIO (MonadicIO a)
into MonadicIO a
). If we have an expression of type x :: MonadicIO (MonadicIO (MonadicIO x))
there are two ways of running it, by using of the two maps:
joinMonadicIO :: MonadicIO (MonadicIO x) -> MonadicIO x
ReturnM io) = io
joinMonadicIO (WriteM fp str io) = WriteM fp str (joinMonadicIO io)
joinMonadicIO (ReadM path io) = ReadM path (joinMonadicIO . io) joinMonadicIO (
assoc1 :: MonadicIO (MonadicIO (MonadicIO x)) -> MonadicIO x
= joinMonadicIO . joinMonadicIO assoc1
or
assoc2 :: MonadicIO (MonadicIO (MonadicIO x)) -> MonadicIO x
= joinMonadicIO . fmap joinMonadicIO assoc2
We really want both assoc1
and assoc2
to be equal, what guarantees that the way we build an expression of type MonadicIO x
does not matter. This is exactly the associativity law for monads. And indeed MonadicIO
is a monad, and joinMonadicIO
is its join
operator. This is in a tight analogy to the associativity law of monoids in MonoidalIO
.
In Haskell we are more accustomed with the monadic bind operator >>=
to build a monadic expression of type m b
from m a
and a continuation a -> m b
. There are two ways to build m d
from ma :: m a
, fab :: a -> m b
and fbc :: b -> m c
:: c -> m d:
ma >>= fab >>= fbc
ma >>= (\a -> fab a >>= fbc)
Associativity for >>=
tells us that these two are equal. This is equivalent with associativity of join
which we expressed above in the form
. join == join . fmap join) :: m (m (m a)) -> m a (join
Note that associativity of >>=
bind expresses the associativity of building a monadic expression, while join
expresses associativity of assembling it from m (m (m a)
. These two are equivalent: each of the associativity law implies the other one under the inverse correspondence: ma >>= f = join $ fmap f ma
(e.g. each bind builds up m (m a)
, but then it join
s it into m a
); the inverse is join = (>>= id)
.
instance Applicative MonadicIO where
pure = ReturnM
<*>) = ap
(
instance Monad MonadicIO where
return = ReturnM
ReturnM x >>= f = f x
WriteM path str io >>= f = WriteM path str (io >>= f)
ReadM path io >>= f = ReadM path (fmap (>>= f) io)
Let me note, GHC’s IO
monad is build differently; to give much more flexibility for building IO
actions for many different operations supported by many different platforms. In the recursive style we need to built in all the operations that are possible to run. This would be too restrictive for a general purpose language. And also for performance reasons its much better to build IO
from native types (e.g. lambdas and types that require MagicHash
). This avoids memory overhead of terms of kind Type
(to be precise: allocation rate in case of running a recursive type). Haskell abstracts over a state monad, e.g. a type s -> (s, a)
(where s
is a state of the world), but it is still a monad, and monad laws guarantee that the semantic of an expression is independent of bracketing of bind (and join) operators. It is also a recursive type, though the recursiveness is hidden in the monadic join
.
By using a recursive IO
, e.g. a usual functional style programming, we end up with a type that satisfies monad laws. The monad associativity guarantees that when we build the expression using do
notation (e.g. >>=
or join
) the bracketing will not change the semantics of an expression.
At last let us point out some benefits of recursive/monadic IO
:
MonoidalIO
we did not have access to data read from a file. In a functional language, recursive / monadic IO does not require any thing more than lambdas to bind the return value.IO
operations are trapped inside the MonoidalIO
monad. This gives a clear indication which functions have access to IO and which are pure.In this posts we will present categories which can run monadic actions, which we call categories with monadic effects (abr. EffCategories
). It turns out that one can build them in an abstract way, much the same way as free monads, and use them to specify state machines in a succinct and type-safe manner.
Most of the abstractions presented in this blog posts are included in the following Hackage packages:
Though this posts is self contained, you might want to first read my earlier posts on finite state machines and categories.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module CategoriesWithMonadicEffects where
import Prelude hiding (id, (.))
import Data.Kind (Type)
import Control.Arrow (Kleisli (..))
import Control.Category (Category (..))
import Control.Monad (void)
import Numeric.Natural (Natural)
import Data.Functor (($>))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Control.Algebra.Free (AlgebraType, AlgebraType0, Proof (..))
import Control.Algebra.Free2 (FreeAlgebra2 (..))
import Test.QuickCheck
Cat
is a free category generated by a transition graph, which itself is represented as a type of kind k -> k -> Type
. Since a graph does not have identity morphisms and lacks composition, the Cat
constructors fill in the gap. Note that there are other representations of free categories, but this one is the most straightforward to work with. But if you need a condensity transformed version check out free-category package.
data Cat :: (k -> k -> Type) -> k -> k -> Type where
Id :: Cat f a a
(:.:) :: f b c -> Cat f a b -> Cat f a c
Category instance for Cat f
is straightforward:
instance Category (Cat f) where
id :: Cat f a a
id = Id
(.) :: Cat f b c -> Cat f a b -> Cat f a c
Id . ys = ys
:.: xs) . ys = x :.: (xs . ys) (x
Cat
is a free construction, this means that we can
f
into Cat f
andforall x y. f x y -> c x y
can be extended uniquely to a functor from the category Cat f
to the category c
, i.e. a graph morphism which preserves identity arrows and composition.These two propositions are proven by the following instance. liftFree2
gives us the embedding and foldNatFree2
transforms graph morphisms into functors.
type instance AlgebraType0 Cat f = ()
type instance AlgebraType Cat c = Category c
instance FreeAlgebra2 Cat where
liftFree2 :: f a b -> Cat f a b
= (:.: Id)
liftFree2
foldNatFree2 :: Category c
=> (forall x y. f x y -> c x y)
-> Cat f a b
-> c a b
Id = id
foldNatFree2 _ :.: ab) = fun bc . foldNatFree2 fun ab
foldNatFree2 fun (bc
= Proof
codom2 = Proof forget2
Let us check that foldNatFree2
indeed preserves identity morphisms and composition. The first one is obvious, since this is how we defined foldNatFree2
, so we are only left with the former claim. We need to consider two cases, following the definition on composition in Cat f
.
foldNatFree2 f (Id . ys)
= foldNatFree2 f ys -- since `Id` is an identity
= id . foldNatFree2 f ys -- since `id` is an identity
= foldNatFree2 f Id . foldNatFree2 ys -- by definition of `foldNatFree`
and
foldNatFree2 f ((x :.: xs) . ys)
-- by definition of multiplication in `Cat f`
= foldNatFree f (x :.: (xs . yx))
-- by definition of `foldNatFree2`
= f x . foldNatFree2 f (xs . yx)
-- by induction hypothesis
= f x . ((foldNatFree2 f xs) . foldNatFree f ys))
-- by associativy of composition
= (f x . foldNatFree2 f xs) . foldNatFree f ys
-- by definition of `foldNatFree2`
= foldNatFree2 f (x :.: xs) . foldNatFree f ys
Since Haskell is bound to monadic IO, if we want to represent a state machine that runs IO actions, we need a way to run monadic computations in the context of categorical composition. The following class is an attempt to give access to both:
-- | Categories which can lift monadic actions, i.e. categories
-- with monadic effects.
--
class Category c => EffCategory c m | c -> m where
lift :: m (c a b) -> c a b
We start with two basic instances. First the pure one:
instance EffCategory (->) Identity where
= runIdentity lift
And another very useful in our context, which is the prototypical example of EffCategory
.
instance Monad m => EffCategory (Kleisli m) m where
= Kleisli (\a -> m >>= \(Kleisli f) -> f a) lift m
We can actually define a category of EffCategories
, in which objects are categories with monadic effects, while morphisms are functors f :: c a b -> c' a b
which satisfy the following property:
f (lift mcab) = lift $ f <$> mcab
You can even define a 2-Category, where natural transformations play the role of 1-morphisms (like the category of categories is defined), but this goes beyond this post.
Free monads are very successful to represent DSLs in an abstract way, and we’d like to have an analog way for building categories with monadic effects. The following definition gives us a free construction of such a category.
It is build abstractly, and its semantics / interpretation is free to be defined in any category with effects, e.g. the pure ->
or in Kleisli IO
or in any other category with effects (in the same monad).
-- | Category transformer, which adds @'EffCategory'@ instance to the
-- underlying base category.
--
data FreeEffCat
:: (Type -> Type)
-> (k -> k -> Type)
-> (k -> k -> Type)
where
Base :: c a b -> FreeEffCat m c a b
Lift :: m (FreeEffCat m c a b) -> FreeEffCat m c a b
Let us first prove that FreeEffCat
is a category, under the assumption that m
is a functor and c
is a category:
instance (Functor m, Category c) => Category (FreeEffCat m c) where
id = Base id
Base f . Base g = Base $ f . g
. Lift mg = Lift $ (f .) <$> mg
f Lift mf . g = Lift $ (. g) <$> mf
The EffCategory
instance is trivial (which is not a coincidence, this is a common pattern across many free constructions; check out instances in free-algebras):
instance (Functor m, Category c) => EffCategory (FreeEffCat m c) m where
= Lift lift
Since a free object requires two operations: the embedding of the original structure plus the required operations (in this case just lift
), FreeEffCat
has two constructors which corresponds to these two operations. With this we can build an instance which proves that FreeEffCat
is indeed a free category with effects.
type instance AlgebraType0 (FreeEffCat m) c = (Monad m, Category c)
type instance AlgebraType (FreeEffCat m) c = EffCategory c m
instance Monad m => FreeAlgebra2 (FreeEffCat m) where
liftFree2 :: c a b
-> FreeEffCat m c a b
= Base
liftFree2
foldNatFree2 :: ( Category f
EffCategory c m
,
)=> (forall x y. f x y -> c x y)
-> FreeEffCat m f a b
-> c a b
Base cab) = nat cab
foldNatFree2 nat (Lift mcab) = lift $ foldNatFree2 nat <$> mcab
foldNatFree2 nat (
= Proof
codom2 = Proof forget2
There is one law that we need to prove, that foldNatFree2
is a morphism between categories with monadic effects, i.e.
foldNatFree2 nat (lift mab) = lift $ foldNatFree2 nat <$> mab
And as you can see it is a straightforward consequence of the definition:
foldNatFree2 nat (lift mcab)
-- by definition of `lift` in `FreeEffCat`
= foldNatFree2 nat (Lift mcab)
-- by definition of `foldNatFree2`
= lift $ foldNatFree2 nat <$> mcab
You can see that it’s actually the only way that foldNatFree2
could be defined so that it satisfies this property.
-- | Wrap a transition into a free category @'Cat'@ and then in
-- @'FreeEffCat'@
--
-- prop> liftCat tr = Base (tr :.: Id)
--
liftCat :: Monad m => tr a b -> FreeEffCat m (Cat tr) a b
= liftFree2 . liftFree2 liftCat
-- | Fold @'FreeEffCat'@ category based on a free category @'Cat' tr@
-- using a functor @tr x y -> c x y@.
--
foldNatLift :: (Monad m, EffCategory c m)
=> (forall x y. tr x y -> c x y)
-> FreeEffCat m (Cat tr) a b
-> c a b
= foldNatFree2 (foldNatFree2 nat) foldNatLift nat
-- | Functor from @'->'@ category to @'Kleisli' m@. If @m@ is @Identity@
-- then it will respect @'lift'@ i.e.
-- @liftKleisli (lift ar) = lift (liftKleisli <$> -- ar).
--
liftKleisli :: Applicative m => (a -> b) -> Kleisli m a b
= Kleisli (pure . f) liftKleisli f
This is enough of abstract constructions, now’s the time to make some concrete usage, and a good point for a break and a walk to digest the contents.
The following example is based on: State Machines All The Way Down by Edwin Brady, youtube The idea is to define a state machine for a logging system, with a strong type properties: let the type checker prove that only logged in user have access to secret data.
StateType
is a promoted kind with two types. It represents two possible states of the login system: logged in or logged out.
-- | Type level representation of the states.
--
data StateType where
LoggedInType :: StateType
LoggedOutType :: StateType
We also define singletons for these promoted types to be able reason about the types on the term level. In Idris, Edwin Brady, could define all the needed machinery on the type level, thanks to stronger type system.
data SStateType (a :: StateType) where
SLoggedIn :: SStateType 'LoggedInType
SLoggedOut :: SStateType 'LoggedOutType
We will also need term level representation of states. LoggedOut
will let us carry out a value which we gained access to when we were logged in. This is a design choice that we want to leak the secret out of the safe zone.
data State (st :: StateType) a where
LoggedIn :: State 'LoggedInType a
LoggedOut :: Maybe a -> State 'LoggedOutType a
runLoggedOut :: State 'LoggedOutType a -> Maybe a
LoggedOut a) = a runLoggedOut (
Next we define a graph of transitions in the state machine.
data Tr a from to where
Login :: SStateType to
-> Tr a (State 'LoggedOutType a) (State to a)
Logout :: Maybe a
-> Tr a (State 'LoggedInType a) (State 'LoggedOutType a)
Access :: Tr a (State 'LoggedInType a) (State 'LoggedInType a)
login :: Monad m
=> SStateType st
-> FreeEffCat m (Cat (Tr a))
State 'LoggedOutType a)
(State st a)
(= liftCat . Login login
logout :: Monad m
=> Maybe a
-> FreeEffCat m (Cat (Tr a))
State 'LoggedInType a)
(State 'LoggedOutType a)
(= liftCat . Logout logout
access :: Monad m
=> FreeEffCat m (Cat (Tr a))
State 'LoggedInType a)
(State 'LoggedInType a)
(= liftCat Access access
type Username = String
Let us build now a data type representation of the state machine. It is good to have an unsafe representation, and we should be able to map it into the safe one. We build a recursive representation of how the state machine can evolve.
For login we need a handler that returns either
HandleAccess
.data HandleLogin m authtoken a = HandleLogin {
handleLogin :: m (Either (HandleLogin m authtoken a) (HandleAccess m a)),
-- ^ either failure with a login continuation or handle access
-- to the secret data
handleAccessDenied :: m ()
-- ^ handle access denied
}
Upon a successful login, we should be able to access the secret data, AccessHandler
is contains an action to get the data (e.g. read it from disc or a database, likely some IO operation) and a handler which let us use it in some way. We should be able to logout from the system and for that we have a second constructor.
data HandleAccess m a where
AccessHandler
:: m a -- access secret
-> (a -> m (HandleAccess m a)) -- handle secret
-> HandleAccess m a
LogoutHandler :: HandleAccess m a -- logout
An example HandleLogin
, which protects the secret with a simple password.
handleLoginIO :: String
-> HandleLogin IO String String
= HandleLogin
handleLoginIO passwd
{ handleLogin
, handleAccessDenied
}where
= do
handleLogin <- putStrLn "Provide a password:" >> getLine
passwd' if passwd' == passwd
then return $ Right handleAccess
else return $ Left $ handleLoginIO passwd
= AccessHandler (pure "44") $
handleAccess -> do
\s putStrLn ("secret: " ++ s)
return LogoutHandler
= putStrLn "AccessDenied" handleAccessDenied
Pure HandleLogin
, which is very useful for testing (e.g. accessSecret
function).
handleLoginPure :: NonEmpty String -- ^ passwords to try (cyclically, ad infinitum)
-> String -- ^ auth token
-> String -- ^ secret
-> HandleLogin Identity String String
= HandleLogin
handleLoginPure passwds passwd secret = handleLogin passwds
{ handleLogin = pure ()
, handleAccessDenied
}where
:| rest) =
handleLogin (passwd' if passwd' == passwd
then return $ Right handleAccess
else case rest of
-> return $ Left $ handleLoginPure passwds passwd secret
[] -> return $ Left $ handleLoginPure (NE.fromList rest) passwd secret _
= AccessHandler (pure secret) $ \_ -> return LogoutHandler handleAccess
Abstract access function, which takes any HandleLogin
representation and maps it into our type safe state machine. Note that the result is guaranteed, by the type system, to have access to the secret only after a successful login.
accessSecret :: forall m a . Monad m
=> Natural
-- ^ how many times one can try to login; this could be
-- implemented inside `HandleLogin` (with a small
-- modifications) but this way we are able to test it
-- with a pure `HandleLogin` (see `handleLoginPure`).
-> HandleLogin m String a
-> FreeEffCat m (Cat (Tr a))
State 'LoggedOutType a)
(State 'LoggedOutType a)
(0 HandleLogin{handleAccessDenied} =
accessSecret $ handleAccessDenied $> id
lift HandleLogin{handleLogin} = lift $ do
accessSecret n <- handleLogin
st case st of
-- login success
Right accessHandler
-> return $ handle accessHandler Nothing . login SLoggedIn
-- login failure
Left handler'
-> return $ accessSecret (pred n) handler'
where
handle :: HandleAccess m a
-> Maybe a
-> FreeEffCat m (Cat (Tr a))
State 'LoggedInType a)
(State 'LoggedOutType a)
(LogoutHandler ma = logout ma
handle AccessHandler accessHandler dataHandler) _ = lift $ do
handle (<- accessHandler
a <- dataHandler a
accessHandler' return $ handle accessHandler' (Just a)
Get data following the protocol defined by the state machine.
Note: in GHC-8.6.1 we’d need MonadFail
which prevents from running this in Identity
monad. To avoid this we use the runLoggedOut
function.
getData :: forall m a . Monad m
=> (forall x y. Tr a x y -> Kleisli m x y)
-> Natural
-> HandleLogin m String a
-> m (Maybe a)
=
getData nat n handleLogin case foldNatLift nat (accessSecret n handleLogin) of
Kleisli fn ->
<$> fn (LoggedOut Nothing) runLoggedOut
To write an interpreter it is enough to supply a natural transformation from Tr a from to
to Kleisli m
for some monad m
.
A pure natural transformation from Tr
to Kleisli m
for some Monad m
. Note, that even though Kleisli
category seems redundant here, as we don’t use the monad in the transformation, we need a transformation into a category that satisfies the EffCategory
constraint. This is because we will need the monad when foldNatLift
will walk over the constructors of the FreeEffCat
category.
natPure :: forall m a from to.
Monad m
=> Tr a from to
-> Kleisli m from to
= liftKleisli . nat
natPure where
-- a natural transformation to @'->'@
nat :: Tr a from to -> (from -> to)
Login SLoggedIn) = \_ -> LoggedIn
nat (Login SLoggedOut) = \_ -> LoggedOut Nothing
nat (Logout ma) = \_ -> LoggedOut ma
nat (Access = \_ -> LoggedIn nat
We can capture a QuickCheck property of getData
and run it in a pure setting, thanks to EffCategory
instance for ->
and the Identity
functor.
prop_getData :: NonEmptyList String
-> String
-> String
-> Positive Int
-> Property
NonEmpty passwds) passwd secret (Positive n)=
prop_getData (let res = runIdentity
$ getData natPure
fromIntegral n)
(
(handleLoginPure (NE.fromList passwds) passwd secret)in if passwd `elem` take n passwds
then res === Just secret
else res === Nothing
Putting this all together we get a simple program:
main :: IO ()
= do
main putStrLn ""
quickCheck prop_getDataputStrLn ""
$ getData natPure 3 (handleLoginIO "password") void
When one executes this program one will get:
Provide a password:
test
Provide a password:
password
secret: 44
Working on a large code base, which many type level features could be
easier with a proper editor support. Finding associated type class
instances or open type families isn't easy at the moment. Existing
solutions like hasktags do not
cover all the new language features, so at times one is left
is searching the tree by hand. Haskell IDE engine, will deliver a very
good solution, but at this time it is still quite hard to find a good
language client for vim
which works out of the box.
Ghc plugin is a good fit for solving this problem, and here are the reasons why:
CPP
pragmas are resolved;hsc2hs
or some other
preprocessor;ghcid
(I haven't tried
yet).Over last two weeks I worked out a quite nice solution ghc-tags-plugin using ghc plugin system: at the moment only the part which has access to parsed tree. This allows to output tags for:
ctags
, so if you want you could append tags generated
by ctags
(i.e. for C
in your project).
Configuration is simple (and possibly can be still improved). For
cabal
you don't need to modify checked files (only
cabal.project.local
). Check out the readme
file for instructions.
If you encounter problems with installation, the
github repo contains
a Makefile
to remove the plugin from the cabal store,
install it, list installed versions. This turned out to be quite useful
during development (co-existence of the same version of the plugin which
depends on an internal library may cause problems).
I have been using this plugin on a daily basis while working on
IOHK
code base which contains
haskell: 214521 (96.22%)
ansic: 5285 (2.37%)
sh: 1868 (0.84%)
javascript: 1019 (0.46%)
cpp: 197 (0.09%)
perl: 63 (0.03%)
lisp: 7 (0.00%)
Navigating the codebase, re-discovering where things were moved after
a refactoring, discovering code in far away from my area of expertise
became much easier.
It has been tested on Windows
and Linux
. The
only requirement is: GHC
version 8.6.5
or later.
Happy Haskelling!
In Universal algebra freeness is a well defined algebraic property. We will explore equational theories which are tightly connected to free algebras. We will consider free monoids. Then we'll explain how monads can be brought into the picture in the context of monoidal categories. This will lead to a precise definition of a free monad as a free monoid.
This post requires familiarity with some very basic Category Theory and does not assume any knowledge on Universal Algebra. Most mathematical notions will be introduced but you might want to dig into literature for some more examples; though most of the books are quite lengthy and not suited for non-mathematicians - you've been warned ;). Knowing this I tried to bring all the required definitions, together with some very basic examples. As you read you may want to read about semigroups, monoids, groups, $G$-sets, lattices, Boolean or Heyting algebras from WikiPedia articles or try to find info on nCatLab (though this is is a heavy resource, with mostly with higher categorical approach, so probably better suited for more familiar readers).
We will need some preliminary definitions. Let's begin with a definition of algebra. For a set $A$ we will denote $A^n$ the $n$-th cartesian product of $A$, i.e. $A^2=A\times A$.
It is an easy observations that homomorphism are closed under composition and since the identity map is always a homomorphism this leads to well defined categories, e.g. category of monoids, category of boolean algebras, category of rings, ...
As you can see the definition of a free algebra requires a context, this interesting in its own! There are free monoids in the class of all monoids and there are free commutative monoids in the class of commutative monoids (i.e. monoids in which $m\cdot n=n\cdot m$ for each elements $m,n$).
Many theories allow free algebras. Let's see some other examples:
This is also true for
semi-rings.
You might have used this fact when using
purescript-validation
library. A free semiring generated by a
type a
has type
[[a]]
; for example
[[()]]
is isomorphic to
$\mathbb{N}[X]$, since (please excuse mixing
Haskell and mathematical notation):
$$[[()]]\simeq[\mathbb{N}]\simeq\mathbb{N}[X]$$
Free algebras play an essential role in a proof of beautiful and outstanding Birkhoff theorem. It states that a class of algebras $\mathcal{C}$ is an equational theory if and only if the class is closed under cartesian products, homomorphic images and subalgebras. Equational theories are classes of algebras which satisfy a set of equations; examples includes: semigroups, monoids, groups or boolean or Heyting algebras but also commutative (abelian) semigroups / monoids / groups, and many other classical algebraic structures.
We need to be a little bit more precise language to speak about equational theories in the full generality of Universal Algebra, which we are going to introduce.
We will denote the set of terms on $X$ by $\mathsf{T}^{(f_i)_{i=1,\dots,n}}(X)$ or simply $\mathsf{T}(X)$.
For example in groups: $x^{-1}\cdot x$, $x\cdot y$ and $1$ (the unit of the group) are terms. Terms are just abstract expressions that one can build using algebraic operations that are supported by the algebra type. Each term $t$ defines a term function on every algebra of the given type. In groups the following terms are distinct but they define equal term function: $x^{-1}\cdot x$ and $1$; on the other hand the two (distinct) terms $(x\cdot y)\cdot z$ and $x\cdot (y\cdot z)$ define equal term functions. The two terms $x\cdot y$ and $y\cdot x$ define distinct term functions (on non commutative groups or commutative monoids). Another example comes from boolean algebras (or more broadly lattice theory) where the two terms $x\wedge (y\vee z)$ and $(x\wedge y)\vee(x\wedge z)$ define equal term functions on Boolean algebras (or more generally distributive lattices). If $t$ is a term then the associated term function on an algebra $\underline{A}$ we let denote by $\tilde{t}^{\underline{A}}$. Term functions are natural to express equalities within a theory. Now we are ready to formally define equational classes of algebras.
For example the class of monoids is an equational theory for $$\mathbf{E}=\bigl\{(1\cdot x,\, x),\; (x\cdot 1,\, x),\; \bigl((x\cdot y)\cdot z,\, x\cdot (y\cdot z)\bigr)\bigr\}$$ i.e. all the algebras with two operations: one of arity 0 (the unit) and one of arity 2 (the multiplication), such that the $1$ is the unit for multiplication $\cdot $ and multiplication is associative. The class of commutative monoids is also an equational theory with one additional equation $(x\cdot y,\, y\cdot x)$. Groups, Boolean or Heyting algebras, lattices are also equational theories.
Coming back to free algebras: it turns out that the set of terms $\mathsf{T}^{(f_i)}(X)$ on a given set of variables $X$ has an algebra structure of type $(f_i)_{i=1,\dots,n}$: it is given by the inductive step in the definition of terms: if $t_i\in \mathsf{T}^{(f_i)}(X)$ for $i=1,\dots,j_i$ then $$ f_j^{\underline{\mathsf{T}^{(f_i)}(X)}}(t_1,\ldots,t_{j_i}) := f_j(t_1,\ldots,t_{j_i})\in \mathsf{T}(X) $$ Furthermore $\underline{\mathsf{T}^{(f_i)}(X)}$ is a free algebra over $X$ in the class of all algebras of the given type $(f_i)_{i=1,\dots,n}$. An extension of a map $h:X\rightarrow\underline{A}=(A,(f_i^{\underline{A}})_{i=1,\ldots,n})$ can be build inductively following the definition of terms and using the homomorphism property: $$ h(f_i(t_1,\ldots,f_{i_j})) := f_i^{\underline{A}}(h(t_1),\ldots,h(t_{i_j})) $$ The map $h$ is indeed a homomorphism: $$ \begin{array}{ll} h\bigl(f_i^{\underline{\mathsf{T}(X)}}(t_1,\ldots,t_{i_j})\bigr) & = h(f_i(t_1,\ldots, t_{i_j}) \\\\ & = f_i^{\underline{A}}(h(t_1),\ldots, h(t_{i_j})) \\\\ \end{array} $$ Note that the class of algebras of the same type is usually very broad, but this is the first approximation to build free algebras in an equational theory. This is just the equational theory for the empty set $\mathbf{E}$.
Let’s see this on an example and let us consider algebras
of the same type as a monoid: with one nullary operation
(unit $1$ or mempty
if you like) and one 2-ary
operation (multiplication / mappend
). Let $X$
be a set of variables. Then $1$ is a valid term, and also
if $t_1$ and $t_2$ are terms on $X$ then also $t_1\cdot
t_2$ is a term, but also $t_1\cdot 1$ and $1\cdot t_2$ are
valid and distinct terms. $\mathsf{T}(X)$ resembles
a monoid but it isn't. It is not associative and the
unitality condition is not valid since $t\cdot 1\neq
t\neq 1\cdot t$ as terms. We still need a way to enforce
the laws. But note that if you have a map
$f:X\rightarrow M$ to a monoid $M$ which you'd like to extend to
a homomorphism $\mathsf{T}(X)\rightarrow M$ that preserves
$1$ (which is not the unit, yet) and multiplication (even
though it is not associative), you don’t have much choice:
$\mathsf{T}(X)\rightarrow M$: $t_1\cdot t_2$ must be mapped
to $f(t_1)\cdot f(t_2)\in M$.
We need a tool to enforce term equations. For that one can use
Equivalence relations and congruences form complete lattices (partial ordered which have all suprema and minima, also infinite). If you have two equivalence relations (congruences) then their intersection (as subsets of $A^2$) is an equivalence relation (congruence).
The set of equations that defines the class of monoids generates a congruence relation on the term algebra $\underline{\mathsf{T}^{f_i}(X)}$ (i.e. an equivalence relation which is compatible with operations: $x_1\sim y_1$ and $x_2\sim y_2$ then $(x_1\cdot y_1) \sim (x_2\cdot y_2)$). One can define it as the smallest congruence relation which contains the set $\mathbf{E}$. Equivalence relation on a set $A$ is just a subset of the cartesian product $A\times A$ (which satisfy certain axioms), so it all fits together! One can describe this congruence more precisely, but we'll be happy with the fact that it exists. To show that, first one need to observe that intersection of congruences is a congruence, then the smallest congruence containing the set $\mathbf{E}$ is an intersection of all congruences that contain $\mathbf{E}$. This intersection is non empty since the set $A\times A$ is itself a congruence relation.
The key point now is that if we take the term algebra and take a quotient by the smallest congruence that contains all the pairs of terms which belong to the set $\mathbf{E}$ we will obtain a free algebra in the equational class defined by $\mathbf{E}$. We will leave the proof to a curious reader.
Let’s take a look on a free monoid that we can build this way. First let us consider the free algebra $\underline{\mathsf{T}(X)}$ for algebras of the same type as monoids (which include non associative monoids, which unit does not behave like a unit). And let $\sim$ be the smallest relation (congruence) that enforces $\mathsf{T}(X)/\sim$ to be a monoid.
Since monoids are associative every element in $\underline{\mathsf{T}(X)}/\sim$ can be represented as $x_1\cdot( x_2\cdot (x_3\cdot\ldots \cdot x_n))$ (where we group brackets to the right). Multiplication of $x_1\cdot( x_2\cdot (x_3\cdot\ldots \cdot x_n))$ and $y_1\cdot( y_2\cdot (y_3\cdot\ldots \cdot y_m))$ is just $x_1\cdot (x_2\cdot (x_3\cdot\ldots\cdot(x_n\cdot (y_1\cdot (y_2\cdot (y_3\cdot\ldots\;\cdot y_m)\ldots)$. In Haskell if you’d represent the set $X$ as a type $a$ then the free monoid is just the list type $[a]$ with multiplication: list concatenation and unit element: the empty list. Just think of
-- A set with `n` elements corresponds
-- to a type with `n` constructors:
data X = X_1|⋯|X_n
It turns out that monads in $\mathcal{Hask}$ are also an equational theory. Just the terms are higher kinded: $*\rightarrow*$ rather than $*$ as in monoids. The same construction of a free algebra works in the land of monads, but we need to look at them from another perspective. Let us first take a mathematical definition of view on monads.
m
with two
natural transformations:
class Monad m where
return :: a -> m a
join :: m(m a) -> m a
which is unital and associative, i.e. the following law holds:
-- | associativity
join . join == join . fmap join
-- | unitality
join . return = id = join . fmap return
These axioms are easier to understand as diagrams:
It is a basic lemma that this definition a monad is equivalent to what we are used to in Haskell:
class Monad m where
return :: a -> m a
>>= :: m a -> (a -> m b) -> m b
Having join
one defines >>=
as
ma >>= f = join $ f <$> ma
and the other way, having >>=
then
join = (>>= id)`
Not only these two constructions are reverse to each other,
but also they translate the monad laws correctly.
Most examples of monoidal categories are not strict but are associative and unital up to a natural transformation. Think of $(A\times B)\times C\simeq A\times(B\times C)$ in $\mathcal{Set}$ (or any category with (finite) products, like $\mathcal{Hask}$). Let me just stress out that since $\otimes$ is a bifunctor, for any two maps $f:\;a_1\rightarrow b_1$ and $g:\;a_2\rightarrow b_2$ we have a map $f\otimes g: a_1\otimes a_2\rightarrow b_1\otimes b_2$, and moreover it behaves nicely with respect to composition: $(f_1\otimes g_1) \cdot (f_2\otimes g_2) = (f_1\cdot f_2)\otimes(g_1\cdot g_2)$ for composable pairs of arrows $f_1,\;f_2$ and $g_1,\;g_2$.
Now we can generalise a definition of a monoid to such categories:
The main point of this section is that these diagrams have exactly the same shape as associativity and unitality for monads. Indeed, a monoid in the category of endo-functors with functor composition as a monoidal product $\otimes$ and unit the identity functor is a monad. In category theory this category is strict monoidal, if you try to type this in Haskell you will end up with a non strict monoidal structure, where you will need to show penthagon equation.
These consideration suggest that we should be able to build a free monad using our algebraic approach to free algebras. And this is what we will follow in the next section.
Firstly, what should replace the set of generators $X$ in
$\mathsf{T}(X)/\sim$?
First we generalised from the category of sets $\mathcal{Set}$ to
a monoidal category $(\mathcal{C},\otimes, 1)$: its clear
that we just should pick an object of the category
$\mathcal{C}$. Now since our category is the category of
(endo) functors of $\mathcal{Hask}$ the set of generators
is just a functor. So let's pick a functor f
.
To get a free monad we need to decypher $\mathsf{T}(f)/\sim$ in the context of a monoid in a monoidal category of endofunctors. Note that here $\mathsf{T}(f)$ and $\mathsf{T}(f)/\sim$ are functors! To simplify the notation, let $\mathsf{Free}(f):=\mathsf{T}(f)/\sim$. So what is a term in this setting? It should be an expressions of a Haskell's type: $$ \begin{equation} \begin{array}{c} \bigl(\mathsf{Free}(f)\otimes\mathsf{Free}(f)\otimes\ldots\otimes \mathsf{Free}(f)\bigr)(a) \\\\ \quad\quad = \mathsf{Free}(f)\bigl(\mathsf{Free}(f)\bigl(\ldots (\mathsf{Free}(f)(a)\bigr)\ldots\bigr) \end{array} \end{equation} $$ In our setup the monoidal product $-\otimes-$ is just the functor composition, thus $\mathsf{Free}(f)(a)$ must be a type which (Haskell's) terms are of Haskell's types:
a, f a, f (f a), f (f (f a)), ...
The monadic join
will take something of
type $\mathsf{Free}(f)\;(\mathsf{Free}(f)\;(a))$, e.g. $f^n(b)=f\;(f\;(\dots f\;(b)\dots)$ (by abusing the notation $f^n$)
where $b$ has type
$f^m(a)=(f\;(f\;(\dots(f\;(a)\dots)$ and return something
of type $\mathsf{Free}(f)(a)$ and it should be quite clear
how to do that: just take the obvious element of type
$f^{n+m}(a)$. Altogether, this is a good trace of a monad,
so let us translate this into a concrete Haskell type:
data Free f a
= Return a
-- ^ the terms of type a
| Free (f (Free f a))
-- ^
-- recursive definition which embraces
-- `f a`, `f (f a)` and so on
instance Functor f => Functor (Free f) where
fmap f (Return a) = Return (f a)
fmap f (Free ff) = Free (fmap (fmap f) ff)
Free f
is just a tree shaped by the functor
f
. This type indeed embraces all the terms of
types: a, f a, f (f a), ...
into a single
type. Now the monad instance:
instance Monad (Free f a) where
return = Return
join (Return ma) = ma
-- ^ stitch a tree of trees into a tree
join (Free fma) = Free $ join <$> fma
-- ^ recurs to the leaves
As you can see, takes a tree of trees and outputs a bigger
tree, that's what join
does on the
Return
constructor.
Before formulating the next result let's describe morphisms
between monads. Let m
and n
be
two monads then a natural transformation
f :: forall a. m a -> n a
is a homomorphism of monads iff the
following two conditions are satisfied:
f . return == return
join . f == f . fmap f . join
Note that this two conditions are satisfied iff
f
is a monoid homomorphism in the category of (endo)functors
of $\mathcal{Hask}$.
f
be a functor, then Free
f
then there exists a morphism:
foldFree :: Functor f => (forall x. f x -> m x) -> (Free f a -> m a)
which restricts to an isomorphism of natural
transformations on the left hand side and monad
homomorphisms on the right hand side, and thus
Free f
is rightly colled free monad..
foldFree
.
foldFree :: Functor f => (forall x. f x -> m x) -> (Free f a -> m a)
foldFree _ (Return a) = return a
foldFree f (Free ff) = join $ f $ foldFree f <$> ff
It's inverse is:
liftF :: Functor f => (forall x. Free f x -> m x) -> (f a -> m a)
liftF f fa = f $ Free $ Return <$> fa
First let's check that foldFree f
is a morhpism of monads:
foldFree f (Return a)
-- | by definition of (foldFree f)
= return a
foldFree f (join (Return a))
= foldFree f a
-- | by monad unitality axiom
= join $ return $ foldFree f $ a
-- | by definition of (foldFree f)
= join $ foldFree f (Return $ foldFree f a)
-- | by definition of functor instance of (Free f)
= join $ foldFree f $ fmap (foldFree f) $ Return a
foldFree f (join (Free ff)
-- | by definition of join for (Free f)
= foldFree f (Free $ fmap join $ ff)
-- | by definition of foldFree
= join $ f $ fmap (foldFree f) $ fmap join $ ff
= join $ f $ fmap (foldFree f . join) $ ff
-- | by induction hypothesis
= join $ f $ fmap (join . foldFree f . fmap (foldFree f)) $ ff
= join $ f $ fmap join $ fmap (foldFree f)
$ fmap (fmap (foldFree f)) $ ff
-- | f is natural transformation
= join $ fmap join $ f $ fmap (foldFree f)
$ fmap (fmap (foldFree f)) $ ff
-- | monad associativity
= join $ join $ f $ fmap (foldFree f)
$ fmap (fmap (foldFree f)) $ ff
-- | by definition of (foldFree f)
= join $ foldFree f $ Free
$ fmap (fmap (foldFree f)) $ ff
-- | by functor instance of (Free f)
= join $ foldFree f $ fmap (foldFree f) $ Free ff
And we have
foldFree . liftF :: (forall x. Free f x -> m x) -> (Free f a -> m a)
(foldFree . liftF $ f) (Return x)
-- ^ where f is a morphism of monads
= foldFree (liftF f) (Return x)
= return x
= f (Return x) -- since f is assumed to be a morphism of monads
(foldFree . liftF $ f) (Free ff)
-- ^ where f is a morphism of monads
= foldFree (liftF f) (Free ff)
= join $ liftF f $ fmap (foldFree (liftF f)) $ ff
-- | by induciton hypothesis
= join $ liftF f $ fmap f $ ff
-- | by definition of (liftF f)
= join $ f $ Free $ fmap Return $ fmap f $ ff
-- | by functor instance of (Free f)
= join $ f $ fmap f $ Free (Return ff)
-- | since f is a morphism of monads
= f $ join $ Free (Return ff)
= f $ Free ff
liftF . foldFree :: (forall x. f x -> m x) -> (f a -> m a)
(liftF . foldFree $ f) fa
-- ^ where f is a natural transformation
= liftF (foldFree f) $ fa
-- | by definition of liftF
= (foldFree f) $ Free $ fmap Return $ fa
-- | by definition of (foldFree f)
= join $ f $ fmap (foldFree f) $ fmap Return $ fa
= join $ f $ fmap (foldFree f . Return) $ fa
-- | by defintion of (foldFree f)
= join $ f $ fmap return $ fa
-- | since f is a natural transformation
= join $ fmap return $ f fa
-- | by monad unitality axiom
= f fa
foldFree
corresponds to foldMap
which is
defined in a very similar way
foldMap :: Monoid m => (a -> m) -> [a] -> m
foldMap _ [] = mempty
foldMap f (a : as) = mappend (f a) (foldMap f as)
Note that foldMap
is an isomorphism onto
monoid homomorphisms with an inverse
g :: Monoid m => ([a] -> m) -> a -> m
g f a = f [a]
Furthermore, if we had polymorphic functions over monoidal
categories in our type system, foldMap
and
foldFree
would be specialisations of the
same function!
data Const a b = Const a
Then Free (Const a)
is isomorphic to Either a
toEither :: Free (Const a) b -> Either a b toEither (Return b) = Right b toEither (Free (Const a)) = Left a fromEither :: Either a b -> Free (Const a) b fromEither (Right b) = Return b fromEither (Left a) = Free (Const a)Since
Either ()
is isomorphic with
Maybe
also Maybe
is a free
monad.
Free Identity
is isomorphic to:
data Nat = Zero | Succ Nat
newtype Writer m a = Writer { runWriter :: (m, a) }
deriving Functor
toFree1 :: Free Identity a -> Writer Nat a
toFree1 (Return a) = Writer (Zero, a)
toFree1 (Free (Identity fa)) = case toFree1 fa of
Writer (n, a) -> (Succ n, a)
fromFree1 :: (Nat, a) -> Free Identity a
fromFree1 (Writer (Zero, a))
= Return a
fromFree1 (Writer (Succ n, a))
= Free (Identity (fromFree1 (Free1 n a)))
Note that Nat
is the free monoid with one
generator (Nat
$\simeq$[()]
) in
the cateogry $\mathcal{Hask}$, and so is Free
Identity
but in the monoidal category of
endofunctors of $\mathcal{Hask}$!
data F2 a = FX a | FY a
deriving Functor
. Then we have
data S2 = SX | SY
toFree2 :: Free F2 a -> Writer [S2] a
toFree2 (Return a) = Writer ([], a)
toFree2 (Free (FX fa)) = case toM2 fa of
Writer (m, a) -> Writer (SX : m, a)
toM2 (Free (FY fa)) = case toM2 fa of
Writer (m, a) -> Writer (SY : m, a)
fromFree2 :: Writer [S2] a -> Free F2 a
fromFree2 (Writer ([], a))
= Return a
fromFree2 (Writer (SX : xs, a))
= Free (FX (fromM2 $ Writer (xs, a)))
fromFree2 (Writer (SY : xs, a))
= Free (FY (fromM2 $ Writer (xs, a)))
toFree2
and fromFree2
are isomorphisms.
I think you see the pattern: if you take a functor with $n$
constructors you will end up with a writer monad over
a free monoid with $n$ generators. You might ask if all
the monads are free then? The answer is no: take a non
free monoid m
then the monad Writer
m
is a non free monad. You can prove your self that
the writer monad Writer m
is free if and only
if the monoid m
is a free monoid in
$\mathcal{Hask}$.
I hope I convinced you that monads are algebraic constructs and I hope you'll find universal algebra approach useful. In many cases we are dealing with algebraic structures which we require to satisfy certain equations. Very often they fit into equational theories, which have a very clear description and which allow free objects. Freeness is the property that lets one easily interpret the free object in any other object of the same type. In the monad setting they are really useful when writing DSLs, since you will be able to interpret it in any monad, like IO or some pure monad.
In this post we will explore finite state machines with typed transitions represented as finite directed graphs via free categories. You will also see how usefull is the Kleisli category.
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module FiniteStateMachines where
import Prelude hiding (id, foldMap, (.))
import Control.Category (Category (..), (<<<))
import Control.Monad ((>=>))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import Data.Void (Void)
import Unsafe.Coerce (unsafeCoerce)
A free category generated by a (directed) graph is formed by adding identity edges to each vertex and then taking the graph of all possible paths, i.e every path in this graph, becomes arrow in the generated category. The final step is to impose category theory laws: so that the added identity arrows satisfy the unit law. Path composition is always associative, so at least this we get for free. Composition of arrows is just composition of paths. Note that this construction correponds exactly to the construction of the free monoid: if you take a graph with a single vertex *
and a bunch of edges from *
to *
then the free monoid generated by this set of edges is the same as the free category (every monoid can be seen as a category with a single object).
data Cat :: (Type -> Type -> Type) -> Type -> Type -> Type where
Id :: Cat f a a
(:.:) :: f b c -> Cat f a b -> Cat f a c
instance Category (Cat f) where
id = Id
Id . ys = ys
:.: xs) . ys = x :.: (xs . ys) (x
Let us check that the category theory laws holds. First let us observe that by recursive definition of Cat
, every element has a form: (f1 :.: (f2 :.: ( ... :.: Id)))
.
The smallest n such that a morphism has this form we call the length of a morphism.
First unit law: Id . x = x
holds by definition; to show x . Id = x
, it’s enough to consider the case when x has length greater than 1:
:.: xs) . Id
(x == x :.: (xs . Id)
-- by induction on the length of xs
== x :.: xs
Now let us prove associativity. The proof is also by induction on the length of the first element:
:.: Id) . y) . z
((x == (x :.: y) . z
== (x :.: (y . z))
== (x :.: (Id . (y . z))
== (x :.: Id) . (y . z)
And the induction step:
:.: xs) . y) . z
((x == (x :.: (xs . y)) . z
== x :.: ((xs . y) . z)
-- by induction on the length of xs
== x :.: (xs . (y . z))
== (x :.: xs) . (y . z)
As expected we have a lawful category Cat f
.
For each a
we have an embedding:
endo :: [f a a] -> Cat f a a
= Id
endo [] : xs) = x :.: endo xs endo (x
As all the free constructions, also free category has the lift operation which let you embed the generating graph into the free category generated by it. It is a generalisation of the singleton list
: []) :: a -> [a] (
and at the same time lift
for monad transformers.
liftCat :: f a b -> Cat f a b
= fab :.: Id liftCat fab
Being a free category means that whenever you have a binatural transformation from f :: Type -> Type -> Type
to a category Category g => g :: Type -> Type -> Type
you can construct (in a unique way) a functor from Cat f
to g
. This is the spirit of free algebras. And indeed we can get a foldMap
like map:
foldFunCat :: forall f g a b . Category g
=> (forall x y. f x y -> g x y)
-- ^ a map of graphs
-> (Cat f a b -> g a b)
-- ^ a functor from 'Cat f' to 'g'
Id = id
foldFunCat _ :.: ab)
foldFunCat fun (bc = fun bc <<< foldFunCat fun ab
This is a free constructions in the sense I’ve been advocating for some time in a series of blog posts: from free algebras to free monads, monadicity, based on free-algebras package (published on hackage).
in Control.Arrow
there is the following construction, which is attributed to a Swiss category theorist Heinrich Kleisli. It turns out that with any moand m
one can associate a category where arrows are a -> m b
instead of a -> b
. Let us investigate this in detail, as this allows for many interesting interpretations.
newtype Kleisli m a b =
Kleisli { runKleisli :: a -> m b }
instance Monad m => Category (Kleisli m) where
id = Kleisli return
Kleisli f . Kleisli g = Kleisli (g >=> f)
The arrow
(>=>) :: (a -> m b) -> (b -> m c) -> a -> m c
>=> g) a = f a >>= g (f
is called Kleisli composition (or if you prefer using join
: \f g a -> join $ fmap g (f a)
). Monadic operations return
and >>=
carry the unitality laws:
return >>= f == f
>>= return == m m
They become even simpler when we re-write them using >=>
:
return >=> f == f
>=> return == f f
This means that Kleisli return
is indeed the identity arrow in Kleisli m
category. It remain to show that the composition is associative, and this, as you can expect, can be derived from the monad associativity law:
>>= (\x -> k x >>= h)
m == (m >>= k) >>= k)
which using Kleisli composition, takes much simpler form (which conveys the reason for the name of this axiom):
>=> (g >=> h)
f == (f >=> g) >=> h
Let us prove this:
>=> (g >=> h)) a
(f == f a >>= (g >=> h)
== f a >>= \b -> g b >>= h)
-- by monadic associativity law
== (f a >>= g) >>= h
== ((f >=> g) a) >>= h
== ((f >=> g) >=> h) a
The associativity of Kleisli composition >=>
is exactly what we need to prove associativity of Kleisli m
category, so we’re done! This is the one of rare cases when using point free style makes the presentation look much easier to read ;).
Also note that there is a functor from (->)
category to Kleisli m
given by
arr :: Monad m => (a -> b) -> Kleisli m a b
= Kleisli $ return . f arr f
It is a part of the Monad m => Arrow (Kleisli m)
instance in Control.Arrow
module of the base package.
There is a worth noting sepcialization of foldFunCat
to Kleisli category:
foldFunKleisli :: forall f m a b . Monad m
=> (forall x y. f x y -> Kleisli m x y)
-> (Cat f a b -> Kleisli m a b)
= foldFunCat foldFunKleisli
if you expand Kleisli
newtype wrapper we will get
foldFunKleisli' :: Monad m
=> (forall x y. f x y -> x -> m y)
-> Cat f a b
-> a -> m b
= runKleisli $ foldFunKleisli (Kleisli . fun) cab foldFunKleisli' fun cab
A final observation, is that in any category the type cat c => c v v
is a monoid with identity id
and multiplication (.)
. In (->)
we have Data.Monoid.Endo
newtype wrapper for that purpose, and it could be generalised:
data Endo c a where
Endo :: Category c => c a a -> Endo c a
instance Semigroup (Endo c a) where
Endo f <> Endo g = Endo (f <<< g)
instance Category c => Monoid (Endo c a) where
mempty = Endo id
This includes Endo (Kleisli m) a ≅ a -> m a
as an example (for a monad m
). If you try to prove the associativity and unit laws for this monoid, you’ll discover that what you need is associativity and unit laws for monad.
As an example let us consder a bifunctor with a single object:
data Single e v a b where
Single :: e -> Single e v v v
VoidSingle :: Void -> Single e v a b
With Single
you can only construct terms of type Single e v v v
, any other term diverge. We need VoidSingle
constructor to provide a Category
type class instance.
In this case endo
is an isomorphism with inverse (modulo Single e v v v ≅ e
):
toList :: Cat (Single e v) v v -> [e]
Id = []
toList Single e :.: es) = e : toList es
toList (VoidSingle e :.: _) = case e of {} toList (
Whenever e
is a Monoid
, Single e v
is a Category
:
idSingle :: Monoid e => Single e v v v
= Single mempty
idSingle
composeSingle :: Monoid e
=> Single e v b c
-> Single e v a b
-> Single e v a c
Single a) (Single b) = Single (a <> b)
composeSingle (VoidSingle e) _ = case e of {}
composeSingle (VoidSingle e) = case e of {} composeSingle _ (
instance Monoid e => Category (Single e v) where
id :: Single e v a a
id = unsafeCoerce (idSingle @e)
.) = composeSingle (
Furthemore, in this case the free category corresponds to free monoid; Cat (Single e v)
is a single object category with
Cat (Single e v) v v ≅ [e]
the free monoid generated on type Single e v v v ≅ e
.
We will show now that foldFunCat
in this case is nothing than a foldMap
:
foldMap :: Monoid m => (a -> m) -> [a] -> m
foldMap _ [] = mempty
foldMap f (a : as) = f a <> foldMap f as
First let us see how foldFuncCat
specializes:
_foldFunCat :: forall e f v a b .
Monoid e
=> (forall x y . f x y -> Single e v x y)
-> Cat f a b
-> Single e v a b
= foldFunCat _foldFunCat
now note that the only natural transformation f x y -> Single e v x y
that we can have are one that comes from a map g :: f v v -> Single e v v v
. Hence foldFunCat
reduces further to to
foldFunCat' :: forall e f v.
Monoid e
=> (f v v -> Single e v v v) -- ≅ f v v -> e
-> Cat f v v -- ≅ [f v v]
-> Single e v v v -- ≅ e
= foldFunCat (unsafeCoerce f) c foldFunCat' f c
Assuming that endo :: f v v -> Cat f v v
is an isomorphism (which it is for a large class of bifunctors, e.g. Single e v
) we have: Cat f v v ≅ [v]
; so we end up with a map Monoid m => (a -> m) -> [a] -> m
which is the claimed foldMap
. Finally, both foldMap
and foldFunCat
are defined using the same recursion pattern, hence they must be equal.
To recap what we have just show: foldFunCat
for f = Single e v
and g = Monoid m => Single e v
is just foldMap
. In this case we can view foldFunCat
as a generalisation foldMap
. There is also another way of coming to this conclusin via free objects (check out free-algebras package.
For this post I picked the example of a state machine explored by Oscar Wickström in his short series about state machines: part 1 and part 2. It is a simple state transition for an online shop. I slightly simplified it, by making the assumption that one can cancel at any stage (just for presentation purposes).
States (vertices of the FSM):
data NoItems = NoItems
newtype HasItems = HasItems (NonEmpty CartItem)
newtype NoCard = NoCard (NonEmpty CartItem)
data CardSelected = CardSelected Card (NonEmpty CartItem)
data CardConfirmed = CardConfirmed Card (NonEmpty CartItem)
data OrderPlaced = OrderPlaced
The shop only sells unit objects (better than seling Void
terms ;) )
type CartItem = ()
Accepted credit cards:
type Card = String
The FTM’s directed graph can be described by a type of kind Type -> Type -> Type
, where first type is the source of an arrow, the second type is its target. Directed graph lack composition, and we will fix this. In this example we take (after Oscar Wickström, though here Cancel
can abort at any stage rather than just during confirmation, just for simplicity):
data Tr s t where
SelectFirst :: CartItem -> Tr NoItems HasItems
Select :: CartItem -> Tr HasItems HasItems
SelectCard :: Card -> Tr HasItems CardSelected
Confirm :: Tr CardSelected CardConfirmed
PlaceOrder :: Tr CardConfirmed OrderPlaced
Cancel :: Tr s NoItems
Category generated by the Tr
graph.
type ShoppingCat a b = Cat Tr a b
As a graph ShoppingCat
has the same vertices as Tr
, but has more edges. Any path that you can follow in the Tr
graph becomes a new edge in ShoppingCat
, e.g. SelectFirst
followed by Select
is a new edge from NoItems
to HasItems
. Note that at this point we don’t have any interpretation of the arrows, we only modeled the shape of the category we want to have. This gives us freedom how to interpret this category in other categories using functors (not to confuse with Functor
instances: these are endofunctors of (->)
).
Interpretation of the Tr
graph in the (->)
category:
natPure :: Tr a b -> a -> b
SelectFirst i) _ = HasItems (i :| [])
natPure (Select i) (HasItems is) = HasItems (i <| is)
natPure (SelectCard c) (HasItems is) = CardSelected c is
natPure (Confirm (CardSelected c is) = CardConfirmed c is
natPure PlaceOrder _ = OrderPlaced
natPure Cancel _ = NoItems natPure
Interpretation of ShoppingCat
in (->)
(a functor between two categories):
checkoutPure :: ShoppingCat a b -> a -> b
= foldFunCat natPure checkoutPure
But we can easily interpret in ShoppingCat
in any Kleisli category, especially in Klesli IO
. Here we lift just the pure interpretation, but equaly well you could do some IO
here.
checkoutM :: forall m a b . Monad m
=> ShoppingCat a b
-> Kleisli m a b
= foldFunCat nat
checkoutM where
nat :: Tr x y -> Kleisli m x y
= arr $ natPure xy nat xy
Unpacking the Kleisli
category gives us:
chechoutM' :: Monad m => ShoppingCat a b -> a -> m b
= runKleisli . checkoutM chechoutM'
The freedom of the choice of monad in the Kleisli category can give you various ways of dealing with exceptional conditions (e.g. not valid card) and error handling (IOException
s …). Also having various interpretation can be very good for testing, e.g. having a reference implementation might be a very good idea to increase assurance of the software you are developing. Check out Duncan Coutts’ lecture on this technique.
We can give a finally tagless description of the shopping category. For that we first define the class of categories in which one can do all the Tr
operations:
class Category c => ShoppingCatT (c :: Type -> Type -> Type) where
selectFirst :: CartItem -> c NoItems HasItems
select :: CartItem -> c HasItems HasItems
selectCard :: Card -> c HasItems CardSelected
confirm :: c CardSelected CardConfirmed
placeOrder :: c CardConfirmed OrderPlaced
cancel :: c s NoItems
instance ShoppingCatT (Cat Tr) where
= liftCat . SelectFirst
selectFirst = liftCat . Select
select = liftCat . SelectCard
selectCard = liftCat Confirm
confirm = liftCat PlaceOrder
placeOrder = liftCat Cancel cancel
There is a unique functor embed :: ShopingCatT c => ShoppingCat a b -> c a b
which with preserves all the operations, e.g.
SelectFirst i) = selectFirst i
embed (Select i) = select i
embed (SelectCard v) = selectCard v
embed (Confirm = confirm
embed PlaceOrder = placeOrder
embed Cancel = cancel embed
This property does not leave any space how this functor has to be implemented, that’s why ShoppingCat
is the initial ShoppingCatT
category.
embed :: forall c a b. ShoppingCatT c
=> ShoppingCat a b
-> c a b
= foldFunCat nat
embed where
nat :: Tr x y -> c x y
SelectFirst i) = selectFirst i
nat (Select i) = select i
nat (SelectCard c) = selectCard c
nat (Confirm = confirm
nat PlaceOrder = placeOrder
nat Cancel = cancel nat
Let us go back to the Single e v
graph.
A graph is complete if every two vertices are connected by a unique edge. It may also happen that all the vertices can be represented by a single type a
. Then the whole theory collapses to a category with a single object, i.e. a monoid (as we discovered earlier for the Single e v
graph). In this case the generating graph can also be reduced to just a single type (usually a sum of all possible events). In this case one can describe the state machine simply by a free monoid [e]
where e
represents the type of events and use the following version of foldMapKleisli
(foldFunCat
) to give interpretations:
foldMapKleisli :: Monad m
=> (e -> Kleisli m v v)
-> [e]
-> Kleisli m v v
= id
foldMapKleisli _ [] : es) = f e <<< foldMapKleisli f es foldMapKleisli f (e
The first argument of foldMapKleisli
maps events to (monadic) state transformations. You can model pure transformations with Kleisli Identity
(Kleisli Identity a v ≅ v -> v
), or you might want to use IO
with Kleisli IO
(Kleisli IO v v ≅ v -> IO v
).
And again, what you are seeing here is foldMap
, this is simply because Kleisli m v v
is a monoid (as every type Category c => cat a a
is). The composition is given by <<<
and mempty
is the identity arrow id
, so the above formula corresponds to foldMap
. This is the very special case if your state machine can be represented as a single object category, i.e. a monoid.