Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
playing back events with applicative projections
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 constant (o : 'out) : Projection<'ev, _, 'out> =
proj (fun _ _ -> ()) (fun _ -> o) ()
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 pair (a : Projection<'ev,_,'outA>) (b : Projection<'ev,_,'outB>) : Projection<'ev, _, 'outA * 'outB> =
proj (fun ev (sa, sb) -> (a.foldState ev sa, b.foldState ev sb))
(fun (sa,sb) -> (a.projection sa, b.projection sb))
(a.emptyState, b.emptyState)
let (<*>) (f : Projection<'ev,'sa,'a ->'b>) (a : Projection<'ev,'sb,'a>) : Projection<'ev,_,'b> =
(fun (f,a) -> f a) <%> pair f a
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))
let inline sumBy f =
aggregate LanguagePrimitives.GenericZero (fun ev s -> f ev + s)
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 loadedCargo (ship : Ship) =
aggregate Set.empty
(fun ev cs ->
match ev with
| Loaded (s, c)
when s = ship ->
Set.add c cs
| Unloaded (s, c)
when s = ship ->
Set.remove c cs
| _ -> cs)
let route (ship : Ship) =
List.rev <%> aggregate []
(fun ev rs ->
match ev with
| Arrived (s, port)
when s = ship ->
port::rs
| _ -> rs)
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
let shipDetails (ship : Ship) =
(fun loc cs rs -> (loc, Set.toList cs, rs)) <%>
locationOf ship <*> loadedCargo ship <*> route ship
module Tests =
open Xunit
open Projections
let refact = Cargo "Refactoring"
let apples = Cargo "apples"
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)
[<Fact>]
let ``only loaded Cargo will appear in the cargo set``() =
let playback =
theShip kr
|> loaded refact
|> loaded apples
|> arrivedIn sfo
|> unloaded apples
|> getPlayback
let cargo =
loadedCargo kr
|> playback
Assert.Equal<Set<_>>(Set.ofList [refact], cargo)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment