Prism.fs

module StackOverFlow =
    type [<Struct>] Prism<'T, 'U> = Prism of ('T -> 'U option)*('T -> 'U -> 'T)

    module Prism =
      module Details =
        let inline empty< ^T when ^T : (static member empty: ^T) > () = 
          (^T : (static member empty: ^T) ())
        let inline apply1< ^T, ^U when ^T : (static member apply: ^U -> ^T) > t =
          (^T : (static member apply: ^U -> ^T) t)
        let inline unapply1< ^T, ^U when ^T : (static member unapply: ^T -> ^U) > u =
          (^T : (static member unapply: ^T -> ^U) u)
      open Details

      let inline prism  g s = Prism (g, s)
      let inline prism' s g = Prism (g, s)

      let inline strongJoin (Prism (tg, ts)) (Prism (ug, us)) =
        let getter t    = 
          match tg t with 
          | None    -> None
          | Some tv -> ug tv
        let setter t v  = 
          match tg t with 
          | None    ->
            ts t (us (empty ()) v)
          | Some tv -> 
            ts t (us tv v)
        prism getter setter

      let inline weakJoin (Prism (tg, ts)) (Prism (ug, us)) =
        let getter t    = 
          match tg t with 
          | None    -> None
          | Some tv -> ug tv
        let setter t v  = 
          match tg t with 
          | None    -> t
          | Some tv -> 
            ts t (us tv v)
        prism getter setter

      let inline lookup key = 
        let getter m    = Map.tryFind key m
        let setter m v  = Map.add key v m
        prism getter setter

      let identity<'T> v : Prism<'T, 'T> = 
        let getter t    = Some t
        let setter t v  = v
        prism getter setter

      let get (Prism (tg, _)) t = tg t
      let set (Prism (_, ts)) v t = ts t v
      let update (Prism (tg, ts)) u t = ts t (u (tg t))
      let inline update' (Prism (tg, ts)) u t = ts t (u (tg t |> Option.defaultWith empty))

      let mapEach (Prism (tg, ts)) m t = ts t (match (tg t) with Some tv -> Seq.map m tv | None -> Seq.empty)

    type Prism<'T, 'U> with
      static member inline ( >-> ) (t, u) = Prism.weakJoin t u
      static member inline ( >+> ) (t, u) = Prism.strongJoin t u

    module Demo =
      open System
      open Prism

      type [<Struct>] EmployeeNo = EmployeeNo of int

      type Position = Contractor | IndividualContributor | Manager

      // Unfortunate but could possibly be generated
      type Employee = 
        {
          No        : EmployeeNo
          Name      : string
          Email     : string
          Hired     : DateTime
          Salary    : decimal
          Position  : Position
        }

        static member _No       = prism' (fun t v -> { t with No        = v }) (fun t -> t.No       |> Some)
        static member _Name     = prism' (fun t v -> { t with Name      = v }) (fun t -> t.Name     |> Some)
        static member _Email    = prism' (fun t v -> { t with Email     = v }) (fun t -> t.Email    |> Some)
        static member _Hired    = prism' (fun t v -> { t with Hired     = v }) (fun t -> t.Hired    |> Some)
        static member _Salary   = prism' (fun t v -> { t with Salary    = v }) (fun t -> t.Salary   |> Some)
        static member _Position = prism' (fun t v -> { t with Position  = v }) (fun t -> t.Position |> Some)

      type Employees = 
        | Employees of Map<EmployeeNo, Employee>

        static member empty     = Employees Map.empty
        static member apply v   = Employees v
        static member unapply v = let (Employees m) = v in m

      type Company =
        {
          Name      : string
          Employees : Map<EmployeeNo, Employee>
        }
        static member _Name       : Prism<Company, _> = prism' (fun t v -> { t with Name      = v }) (fun t -> t.Name       |> Some)
        static member _Employees  : Prism<Company, _> = prism' (fun t v -> { t with Employees = v }) (fun t -> t.Employees  |> Some)

      open Prism

      let updateEmail employee employeeNo newEmail =
        employee 
        |> set (Company._Employees >-> lookup employeeNo >-> Employee._Email) newEmail 

      let updatePosition employee employeeNo newPosition newSalary =
        employee 
        |> set (Company._Employees >-> lookup employeeNo >-> Employee._Position) newPosition 
        |> set (Company._Employees >-> lookup employeeNo >-> Employee._Salary  ) newSalary