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