Encoding "van Laarhoven" lenses in OCaml

lens.ml

module type Functor = sig
    type 'a t
    val map : ('a -> 'b) -> 'a t -> 'b t
end

module type Lens = sig
    type a
    type b

    module Make(F : Functor) : sig
        val lens : (b -> b F.t) -> (a -> a F.t)
    end
end

module Const = functor(A : sig type t end) -> (struct
    type 'a t = A.t

    let make v = v
    let run v = v
    let map _ v = v
end : sig
    type 'a t
    include Functor with type 'a t := 'a t
    val make : A.t -> 'a t
    val run : 'a t -> A.t
end)

let get (type a) (type b) (module L : Lens with type a = a and type b = b) (a : a) : b =
    let module C = Const(struct type t = b end) in
    let module M = L.Make(C) in
    C.run (M.lens C.make a)

module Identity : sig
    type 'a t = 'a
    include Functor with type 'a t := 'a t
    val make : 'a -> 'a t
    val run : 'a t -> 'a
end = struct
    type 'a t = 'a
    let make v = v
    let run v = v

    let map f v = f v
end

let modify (type a) (type b) (module L : Lens with type a = a and type b = b) (m : b -> b) (c : a) : a =
    let module M = L.Make(Identity) in
    Identity.run (M.lens (fun f -> Identity.make (m f)) c)

let set (type a) (type b) (module L : Lens with type a = a and type b = b) b a =
    let const v _ = v in
    modify (module L) (const b) a


module Demo = struct
    type t = { name : string
             ; age : int
             }

    let make name age = { name; age }

    module Name : Lens with type a = t and type b = string = struct
        type a = t
        type b = string

        module Make(F : Functor) = struct
            let lens f t = F.map (fun n' -> { t with name=n' }) (f t.name)
        end
    end

    module Age : Lens with type a = t and type b = int = struct
        type a = t
        type b = int

        module Make(F : Functor) = struct
            let lens f t = F.map (fun a' -> { t with age=a' }) (f t.age)
        end
    end
end

let main () =
    let open Demo in
    let t = make "Nicolas" 27 in
    let t' = modify (module Name) (fun n -> n ^ " Trangez") t in
    let t'' = set (module Age) 28 t' in
    print_endline (get (module Name) t'')
;;

main ()