playing back events with applicative projections

EventPlaybackApplicative.fs

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)