Lenses à la van Laarhoven

van-laarhoven-lenses.cs

public struct Store<A, B> {
  // Setter of accessor (A), return new object (B)
  public readonly Func<A, B> Put;
  // Getter/Value of accessor (A)
  public readonly A Pos;
  
  public Store(Func<A, B> put, A pos) {
    Put = put;
    Pos = pos;
  }
}

public static class Store {
  public static Store<A, B> Create<A, B>(Func<A, B> put, A pos) {
    return new Store<A, B>(put, pos);
  }
}

public struct Lens<A, B> {
  private readonly Func<A, Store<B, A>> _fn;
  
  public Lens(Func<A, Store<B, A>> fn) {
    _fn = fn;
  }
  
  public Store<B, A> Run(A a) {
    return _fn(a);
  }
  
  public B Get(A a) {
    return Run(a).Pos;
  }
  
  public A Set(A a, B b) {
    return Run(a).Put(b);
  }
  
  public Func<A, A> Modify(Func<B, B> fn) {
    var t = this;
    return a => {
      var x = t.Run(a);
      return x.Put(fn(x.Pos));
    };
  }
  
  public Lens<A, C> Then<C>(Lens<B, C> w) {
    var t = this;
    return Lens.Create<A, C>(a => {
      Store<B, A> y = t.Run(a);
      Store<C, B> z = w.Run(y.Pos);
      return Store.Create<C, A>(c => y.Put(z.Put(c)), z.Pos);
    });
  }
}

public static class Lens {
  public static Lens<A, B> Create<A, B>(Func<A, Store<B, A>> fn) {
    return new Lens<A, B>(fn);
  }
  
  public static Lens<Tuple<A, B>, A> First<A, B>() {
    return Lens.Create<Tuple<A, B>, A>(p =>
      Store.Create(a => Tuple.Create(a, p.Item2), p.Item1));
  }
  
   public static Lens<Tuple<A, B>, B> Second<A, B>() {
    return Lens.Create<Tuple<A, B>, B>(p =>
      Store.Create(b => Tuple.Create(p.Item1, b), p.Item2));
  }
}

van-laarhoven-lenses.fs

type Store<'s, 'a> = { put : 's -> 'a; pos : 's }
type Lens<'a, 'b> = { run : 'a -> Store<'b, 'a> }

let get (l: Lens<'a, 'b>) (a: 'a) = (l.run a).pos
let set (l: Lens<'a, 'b>) (a: 'a) (b: 'b) = (l.run a).put b
let modify (l: Lens<'a, 'b>) (f: 'b -> 'b) = fun a -> let x = l.run(a)
                                                      x.put(f(x.pos))

let lens (f: 'a -> Store<'b, 'a>) = { run = f }
let store (f: 's -> 'a) (s: 's) =  { put = f; pos = s }

// Lens composition
let (>->) (l1: Lens<_, _>) (l2: Lens<_, _>) =
  lens (fun a -> let y = l1.run(a)
                 let z = l2.run(y.pos)
                 store (z.put >> y.put) z.pos)

// Lenses for pairs
// Screw the value restriction!
let fst () = lens (fun p -> match p with (a, b) -> store (fun a1 -> (a1, b)) a)
let snd () = lens (fun p -> match p with (a, b) -> store (fun b1 -> (a, b1)) b)

let nested = (1, (2, (3, 4)))

get (snd() >-> fst()) nested |> printf "get: %A"
set (snd() >-> snd() >-> fst()) nested 5 |> printf "set: %A"
modify (snd() >-> snd() >-> snd()) (fun x -> x * 3) nested |> printf "modify: %A"