OCaml van Laarhoven CPS lenses.

vlcps.ml

module Sum = struct
  type (+'a, +'b) sum = Inl of 'a | Inr of 'b
  type (+'a, +'b) t = ('a, 'b) sum

  let bimap f g = function
    | Inl a -> Inl (f a)
    | Inr b -> Inr (g b)

  let lmap f = bimap f (fun x -> x)
  let rmap f = bimap (fun x -> x) f

  let fold f g = function
    | Inl a -> f a
    | Inr b -> g b

  module Left = struct
    type (+'a, +'b) t = ('a, 'b) sum
    let pure a = Inl a
    let map f = lmap f
    let ap ef ex = match ef, ex with
      | Inl ef, Inl ex -> Inl (ef ex)
      | Inr x,  _      -> Inr x
      | _,      Inr x  -> Inr x
  end

  module Right = struct
    type (+'a, +'b) t = ('a, 'b) sum
    let pure a = Inr a
    let map f = rmap f
    let ap ef ex = match ef, ex with
      | Inr ef, Inr ex -> Inr (ef ex)
      | Inl x,  _      -> Inl x
      | _,      Inl x  -> Inl x
  end
end

module Optic : sig
  type (-'s, +'t, +'a, -'b) t
  type ('s, 'a) ut = ('s, 's, 'a, 'a) t

  val lens  : ('s -> 'a) -> ('s -> 'b -> 't) -> ('s, 't, 'a, 'b) t
  val prism : ('b -> 't) -> ('s -> ('t, 'a) Sum.t) -> ('s, 't, 'a, 'b) t

  val ( >> ) : ('a, 'b, 'c, 'd) t -> ('c, 'd, 'e, 'f) t -> ('a, 'b, 'e, 'f) t
  val id : ('s, 'a, 's, 'a) t

  val _1 : ('a * 'x, 'b * 'x, 'a, 'b) t
  val _2 : ('x * 'a, 'x * 'b, 'a, 'b) t

  val _Inl : (('a, 'x) Sum.t, ('b, 'x) Sum.t, 'a, 'b) t
  val _Inr : (('x, 'a) Sum.t, ('x, 'b) Sum.t, 'a, 'b) t

  val over : ('s, 't, 'a, 'b) t -> ('a -> 'b) -> ('s -> 't)
end = struct
  type (-'s, +'t, +'a, -'b) t = { op : 'r . ('a -> ('b -> 'r) -> 'r) -> ('s -> ('t -> 'r) -> 'r) }
  type ('s, 'a) ut = ('s, 's, 'a, 'a) t

  let lens get set =
    let op cont this read = cont (get this) (fun b -> read (set this b))
    in { op }

  let ( >- ) f g x = f (g x)
  let flip f x y = f y x

  let prism review peel =
    let op cont this read =
      Sum.fold read (flip cont (read >- review)) (peel this)
    in { op }

  let ( >> ) f g = { op = fun z -> f.op (g.op z) }
  let id = { op = fun f -> f }

  (* The following fails due to the value restriction.

         let _1 = let build (_, b) a = (a, b) in lens fst build

     This essentially sinks this method of encoding lenses. *)
  let _1 = { op = fun cont (a, x) read -> cont a (fun b -> read (b, x)) }
  let _2 = { op = fun cont (x, a) read -> cont a (fun b -> read (x, b)) }

  let _Inl =
    let op cont this read = match this with
      | Sum.Inl a      -> cont a (fun b -> read (Sum.Inl b))
      | Sum.Inr _ as x -> read x
    in { op }

  let _Inr =
    let op cont this read = match this with
      | Sum.Inl _ as x -> read x
      | Sum.Inr a      -> cont a (fun b -> read (Sum.Inr b))
    in { op }

  let over l f s = l.op (fun a br -> br (f a)) s (fun x -> x)
  let set l a0 s = over l (fun _ -> a0) s
end