OCaml van Laarhoven CPS lenses + eta expansion

optic.ml

(*
    OCaml van Laarhoven CPS lenses. https://gist.github.com/tel/08d2a94de21f483cbb20
   plus eta expansion
   https://stackoverflow.com/questions/29187287/sneaking-lenses-and-cps-past-the-value-restriction
   *)

type (-'s, +'t, +'a, -'b) _t =
  { op : 'r. ('a -> ('b -> 'r) -> 'r) -> ('s -> ('t -> 'r) -> 'r) }

type (-'s, +'t, +'a, -'b) t = unit -> ('s, 't, 'a, 'b) _t

let lens get set =
  let op acont s tcont =
    acont (get s) (fun b -> tcont (set s b))
  in { op }

let prism construct destruct =
  let op acont s tcont =
    Result.fold (destruct s)
      ~error:tcont
      ~ok:(fun x -> acont x (fun b -> tcont (construct b)))
  in { op }

let prism' construct destruct =
  prism construct (fun s ->
      match destruct s with
      | Some x -> Result.ok x
      | None -> Result.error s)

let app lens = (lens ()).op

let (//) f g () = { op = fun z -> app f (app g z) }

let id () = { op = Fun.id }

let _1 () = lens fst (fun (_, x) b -> (b, x))
let _2 () = lens snd (fun (x, _) b -> (x, b))

let _Ok () =
  prism Result.ok
    (function
      | Result.Ok x -> Result.ok x
      | Result.Error _ as x -> Result.error x)

let _Error () =
  prism Result.error
    (function
      | Result.Error x -> Result.ok x
      | Result.Ok _ as x -> Result.error x)

let _Some () =
  prism Option.some
    (function
      | Some x -> Result.ok x
      | None as x -> Result.error x)

let over lens f s =
  app lens (fun a bcont -> bcont (f a)) s Fun.id

let set lens v s =
  over lens (Fun.const v) s

let get lens s =
  app lens Fun.const s (fun _ -> assert false)

let (.%[]<-) s lens v =
  set lens v s

let (.%[]) s lens =
  get lens s

optic.mli

type (-'s, +'t, +'a, -'b) _t
type (-'s, +'t, +'a, -'b) t = unit -> ('s, 't, 'a, 'b) _t

val lens   : ('s -> 'a) -> ('s -> 'b -> 't) -> ('s, 't, 'a, 'b) _t

val prism  : ('b -> 't) -> ('s -> ('a, 't) Result.t) -> ('s, 't, 'a, 'b) _t
val prism' : ('b -> 's) -> ('s ->       'a Option.t) -> ('s, 's, '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 _Ok    : (('a, 'x) Result.t, ('b, 'x) Result.t, 'a, 'b) t
val _Error : (('x, 'a) Result.t, ('x, 'b) Result.t, 'a, 'b) t

val _Some : ('a Option.t, 'b Option.t, 'a, 'b) t

val over : ('s, 't, 'a, 'b) t -> ('a -> 'b) -> ('s -> 't)
val set : ('s, 't, 'a, 'b) t -> 'b -> 's -> 't
val get : ('s, 't, 'a, 'b) t -> 's -> 'a
val (.%[]<-) : 's -> ('s, 't, 'a, 'b) t -> 'b -> 't
val (.%[]) : 's -> ('s, 't, 'a, 'b) t -> 'a