Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
playing back events with FUN
namespace Events
type Projection<'ev, 'state, 'out> =
{ foldState : 'ev -> 'state -> 'state
; projection : 'state -> 'out
; emptyState : 'state
}
module Projections =
let private proj foldS proj empty =
{ foldState = foldS; projection = proj; emptyState = empty }
let map (f : 'outA -> 'outB) (p : Projection<'ev, _, 'outA>) : Projection<'ev, _, 'outB> =
proj p.foldState (p.projection >> f) p.emptyState
let aggregate (init : 'state) (ag : 'ev -> 'state -> 'state) : Projection<'ev, _, 'state> =
proj ag id init
let (<%>) = map
let (<|>) (a : 'a option) (b : 'a option) =
match (a,b) with
| (None, _) -> b
| (Some _, _) -> a
let latest (f : 'ev -> 'a option) : Projection<'ev,_,'a option> =
aggregate None (fun ev lt -> (f ev <|> lt))
type IPlayback<'ev> =
abstract Playback : Projection<'ev, 'state, 'out> -> 'out
module PlaybackDevices =
let private foldBack (f : 'ev -> 'state -> 'state) (empty : 'state) (evs : 'ev seq) =
let enum = evs.GetEnumerator()
let rec fold cont =
if not (enum.MoveNext())
then cont empty
else
let cur = enum.Current
fold (fun state -> f cur state |> cont)
fold id
let fromEventSeq (evs : 'ev seq) : IPlayback<'ev> =
{ new IPlayback<'ev> with
member __.Playback p =
evs
|> foldBack p.foldState p.emptyState
|> p.projection
}
namespace Events.ShipTrackingExample
open Events
open Events.Projections
module ShipTracking =
type Country =
| US
| CANADA
type Cargo = Cargo of string
type Port = Port of string * Country
type Ship = Ship of string
let countryOfPort (Port (_, c)) = c
type Event =
| Arrived of Ship * Port
| Departed of Ship
| Loaded of Ship * Cargo
| Unloaded of Ship * Cargo
module Projections =
type Location =
| AtPort of Port
| AtSea
| Unknown
let locationOf (ship : Ship) =
(function None -> Unknown | Some l -> l) <%>
latest (function
| Arrived (s,p) when s = ship -> Some (AtPort p)
| Departed s when s = ship -> Some AtSea
| _ -> None)
let portHistory (cargo : Cargo) =
fst <%> aggregate
([], None)
(fun ev (vs, onShip) ->
match ev with
| Arrived (ship, port)
when Some ship = onShip ->
(port::vs, onShip)
| Loaded (ship, c)
when c = cargo ->
(vs, Some ship)
| Unloaded (_, c)
when c = cargo ->
(vs, None)
| _ -> (vs, onShip))
let containerHasBeenIn (cargo : Cargo) (country : Country) =
List.exists (fun port -> countryOfPort port = country)
<%> portHistory cargo
let locationOfCargo (cargo : Cargo) =
List.head
<%> portHistory cargo
module Tests =
open Xunit
open Projections
let refact = Cargo "Refactoring"
let kr = Ship "King Roy"
let sfo = Port ("San Fransisco", US)
let la = Port ("Los Angeles", US);
let yyv = Port ("Vancouver", CANADA)
let theShip ship =
(ship, [])
let getPlayback (_, evs) =
let device = PlaybackDevices.fromEventSeq evs
device.Playback
let arrivedIn port (ship, evs) =
(ship, Arrived (ship, port) :: evs)
let departed (ship, evs) =
(ship, Departed ship :: evs)
let loaded cargo (ship, evs) =
(ship, Loaded (ship, cargo) :: evs)
let unloaded cargo (ship, evs) =
(ship, Unloaded (ship, cargo) :: evs)
[<Fact>]
let ``Arriaval sets Ships location``() =
let playback =
theShip kr
|> arrivedIn sfo
|> getPlayback
let location = playback <| locationOf kr
Assert.Equal(AtPort sfo, location)
[<Fact>]
let ``Departure puts Ship out to Sea``() =
let playback =
theShip kr
|> arrivedIn la
|> arrivedIn sfo
|> departed
|> getPlayback
let location = playback <| locationOf kr
Assert.Equal(AtSea, location)
[<Fact>]
let ``Visiting Canada marks Cargo``() =
let playback =
theShip kr
|> loaded refact
|> arrivedIn yyv
|> departed
|> arrivedIn sfo
|> unloaded refact
|> getPlayback
let refactWasInCanada =
containerHasBeenIn refact CANADA
|> playback
Assert.True refactWasInCanada
[<Fact>]
let ``Arrival with cargo marks the cargos location``() =
let playback =
theShip kr
|> loaded refact
|> arrivedIn yyv
|> getPlayback
let location =
locationOfCargo refact
|> playback
Assert.Equal (yyv, location)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment