Skip to content

Instantly share code, notes, and snippets.

@leque

leque/optic.ml

Last active Dec 22, 2020
Embed
What would you like to do?
OCaml van Laarhoven CPS lenses + eta expansion
(*
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
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment