existential projections in F#

ExProj.fsx

// Projektion

type Key = int

type Projection<'ev,'st,'res> =
    {
        init : Key -> 'st
        fold : 'st -> 'ev -> 'st
        final : 'st -> 'res
    }

let combine (prA : Projection<'ev,'sta,'resa>) (prB : Projection<'ev,'stb,'resb>) 
      : Projection<'ev,'sta*'stb,'resa*'resb> =
  {
    init = fun key -> prA.init key, prB.init key
    fold = fun (sta, stb) ev -> (prA.fold sta ev, prB.fold stb ev)
    final = fun (sta, stb) -> (prA.final sta, prB.final stb)
  }


type IApplyProjection<'ev,'res,'a> =
    abstract Apply : Projection<'ev,'st,'res> -> 'a


type IProjection<'ev,'res> =
    abstract Proj<'a> : IApplyProjection<'ev,'res,'a> -> 'a


let wrap (x : Projection<'ev,'st,'res>) = 
    { new IProjection<'ev,'res> with 
        member __.Proj(f) = f.Apply(x) 
    }


let createProj (init : Key -> 'st) (fold : 'st -> 'ev -> 'st) (final : 'st -> 'res) =
    {
        init = init
        fold = fold
        final = final
    }
    |> wrap


let pureP x =
  createProj ignore (fun () _ -> ()) (fun _ -> x)

// this is the price of having to use interfaces for rank-2 types
let inParallel (pa : IProjection<'ev,'a>) (pb : IProjection<'ev,'b>) =
  { new IProjection<'ev,'a*'b> with 
      member __.Proj(f) =
        { new IApplyProjection<'ev,'a,_> with
          member __.Apply(prA) =
            { new IApplyProjection<'ev,'b,_> with
              member __.Apply(prB) =
                combine prA prB
                |> f.Apply 
            }
            |> pb.Proj
        }
        |> pa.Proj
  }

let pMap (f : 'a -> 'b) (pA : IProjection<'ev,'a>) =
  { new IProjection<'ev,'b> with 
      member __.Proj(pB) =
        { new IApplyProjection<'ev,'a,_> with
          member __.Apply(prA) =
            {
              init = fun key -> prA.init key
              fold = fun st ev -> prA.fold st ev
              final = fun st -> f (prA.final st)
            }
            |> pB.Apply
        }
        |> pA.Proj
  }


let pApp (pF : IProjection<'ev,'a -> 'b>) (pA : IProjection<'ev,'a>) =
  inParallel pF pA
  |> pMap (fun (f,a) -> f a)
  

let (<*>) pF pA = pApp pF pA  
  

let project (p : IProjection<'ev,'res>) (key : Key) (evs : 'ev list) : 'res =
    { new IApplyProjection<'ev,'res,_> with
        member __.Apply proj =
            proj.init key
            |> List.foldBack (fun ev st -> proj.fold st ev) evs
            |> proj.final        
    }
    |> p.Proj 


let last (select : 'ev -> 'res option) = 
  createProj 
    (fun _ -> None) 
    (fun found ev ->
      match select ev with
      | None -> found
      | Some _ as newer -> newer)
    id


let keyP () =
  createProj
    id
    (fun key _ -> key)
    id

type Events =
  | AgeSet of int
  | NameSet of string


let events =
  [
    AgeSet 10
    NameSet "Carsten"
    AgeSet 37
  ]


type Person =
  {
    id : Key
    name : string
    age : int
  }  


let personP = 
  let nameP = 
    last (function NameSet n -> Some n | _ -> None)  
    |> pMap (fun o -> defaultArg o "")

  let ageP = 
    last (function AgeSet a -> Some a | _ -> None)  
    |> pMap (fun o -> defaultArg o 0)
  pureP (fun k n a -> { id = k; name = n; age = a })
  <*> keyP () <*> nameP <*> ageP


[<EntryPoint>]
let main _ =
  printfn "Person: %A" (project personP 0 events)
  0