rewrite of https://gist.github.com/leque/6dd5996b52111d7f8c12b8496b7f1688 with cps fn

optic.ml

module Either = struct
  type ('a, 'b) t = Left of 'a | Right of 'b
  let left v = Left v
  let right v = Right v

  let fold ~left ~right = function
    | Left v -> left v
    | Right v -> right v
end

type (-'s, +'t) fn = {f: 'r. 's -> ('t -> 'r) -> 'r}

let call f = f.f
let cont_of_fn f =
  { f = fun x cont -> cont (f x) }


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

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

let prism construct destruct =
  let op acont =
    {
      f = fun s tcont -> Either.fold (destruct s)
            ~left:tcont
            ~right:(fun x -> call acont x (fun b -> tcont (construct b)))
    }
  in op

let app lens f = call (lens (cont_of_fn f))

let (>>) f g x = f (g x)

let id x = x


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

let _Left () =
  prism Either.left
    (function
      | Either.Left x -> Either.right x
      | Either.Right _ as x -> Either.left x)

let _Right () =
  prism Either.right
    (function
      | Either.Right x -> Either.right x
      | Either.Left _ as x -> Either.left x)

let _Some () =
  prism Option.some
    (function
      | Some x -> Either.right x
      | None as x -> Either.left 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) fn
type (-'s, +'t, +'a, -'b) t = ('a, 'b) fn -> ('s, 't) fn

val lens  : ('s -> 'a) -> ('s -> 'b -> 't) -> ('s, 't, 'a, 'b) t
val prism : ('b -> 't) -> ('s -> ('t, 'a) Either.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 _Left  : (('a, 'x) Either.t, ('b, 'x) Either.t, 'a, 'b) t
val _Right : (('x, 'a) Either.t, ('x, 'b) Either.t, 'a, 'b) t
val _Some : ('a option, 'b option, '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