FsLenses

lenses.fs

module FsLenses =
  type [<AbstractClass>] Lens<'S, 'T, 'A, 'B>() =
    class
      abstract View:  'S -> 'A
      abstract Over:  ('A -> 'B) -> 'S -> 'T
      abstract Set :  'B -> 'S -> 'T
    end

  module Lens =
    let inline view (l : Lens<_, _, _, _>) s   = l.View s
    let inline over (l : Lens<_, _, _, _>) f s = l.Over f s
    let inline set  (l : Lens<_, _, _, _>) v s = l.Set  v s

    let inline lens getter setter =
      { new Lens<'S, 'T, 'A, 'B>() with
          override x.View s   = getter s
          override x.Over f s = setter (getter s |> f) s
          override x.Set  v s = setter v s
      }

    let inline combine a b =    
      { new Lens<'S, 'T, 'A, 'B>() with
          override x.View s   = s |> view a |> view b
          override x.Over f s = s |> set a (s |> view a |> over b f)
          override x.Set  v s = s |> set a (s |> view a |> set b v)
      }

    let inline fstL () = lens fst (fun f (_, s) -> (f, s))
    let inline sndL () = lens snd (fun s (f, _) -> (f, s))

  type Lens<'S, 'T, 'A, 'B> with
    static member inline (>->) (a, b) = Lens.combine a b

open FsLenses    
open Lens

type Inner<'A> =
  {
    Id    : int
    Value : 'A
  }

module Inner =
  let inline idL    () = lens (fun {Id    = id} -> id) (fun id i           -> { i with Id = id})
  let inline valueL () = lens (fun {Value = v } -> v ) (fun v  { Id = id } -> { Id = id; Value = v})

type Outer<'A> =
  {
    Id    : int
    Inner : Inner<'A>
  }

module Outer =
  let inline idL    () = lens (fun {Id    = id} -> id) (fun id o          -> { o with Id = id})
  let inline innerL () = lens (fun {Inner = i } -> i ) (fun i { Id = id } -> { Id = id; Inner = i})

[<EntryPoint>]
let main argv = 
  do
    let i = (1, (2, "3"))
    let l = sndL () >-> fstL ()
    let v = view l i
    let o = i |> set l "4"

    printfn "%A" i
    printfn "%A" v
    printfn "%A" o

  do
    let i = { Id = 1; Inner = { Id = 11; Value = 123 } }
    let l = Outer.innerL () >-> Inner.valueL ()
    let v = view l i
    let o = i |> over l (fun v -> v + 1 |> string)

    printfn "%A" i
    printfn "%A" v
    printfn "%A" o

  0

lenses2.fs

// Inspired by: http://www.fssnip.net/7Pk
module FsLenses =

  type [<AbstractClass>] Functor<'T> () =
    class
      abstract fmap: ('T -> 'U) -> Functor<'U>
    end

  type [<Sealed>] Const<'C, 'T> (c: 'C) =
    class
      inherit Functor<'T> ()
      override x.fmap f = Const<'C, 'U> (c) :> Functor<'U>
      member x.Value = c
    end

  type [<Sealed>] Identity<'T> (v: 'T) =
    class
      inherit Functor<'T> ()
      override x.fmap f = Identity<'U> (f v) :> Functor<'U>
      member x.Value = v
    end

  let fConst    c = Const<_, _> (c) :> Functor<_>
  let fIdentity v = Identity<_> (v) :> Functor<_>

  type Lens<'S, 'T, 'A, 'B> = 
    | L of (('A -> Functor<'B>) -> ('S -> Functor<'T>))
    member x.F = let (L f) = x in f

  type Lens<'S, 'T, 'A, 'B> with
    static member (>->) (L a, L b) = L (b >> a)

  module Lens =
    let view (l : Lens<'S, 'T, 'A, 'B>) s =
      let c = (s |> l.F fConst) :?> Const<'A, _>
      c.Value
    
    let update (l : Lens<'S, 'T, 'A, 'B>) f s =
      let i = (s |> l.F (f >> fIdentity)) :?> Identity<_>
      i.Value

    let set (l : Lens<'S, 'T, 'A, 'B>) v s = s |> update l (fun _ -> v)

    let lens get set : Lens<'S, 'T, 'A, 'B> =
      L (fun f s -> (get s |> f).fmap (fun v -> set v s))

    let fstL () = lens fst (fun f (_, s) -> (f, s))
    let sndL () = lens snd (fun s (f, _) -> (f, s))

open FsLenses    
open Lens

[<EntryPoint>]
let main argv = 
  let i = (1, (2, "3"))
  let l = sndL () >-> fstL ()
  let v = view l i
  let o = i |> set l 4

  printfn "%A" i
  printfn "%A" v
  printfn "%A" o

  0