Skip to content

Instantly share code, notes, and snippets.

@KeenS

KeenS/optic.ml

Created Dec 20, 2020
Embed
What would you like to do?
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
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment