OCaml lens

.gitignore

*.cm*
/a.out

base.ml

let id x = x
let (%) g f x = g (f x)
let const k _ = k
let first f (x, y) = f x, y
let second f (x, y) = x, f y
let opt_of_res res = match res with Error _ -> None | Ok a -> Some a
let map_res f res = match res with Error e -> Error e | Ok a -> Ok (f a)
let map2_res fl fr res = match res with | Error e -> fl e | Ok a -> fr a

(** Functor type. Note: not exactly the same as ocaml's "functors". *)
module type Functor = sig
  type 'a ctx
  val (<$>) : ('a -> 'b) -> 'a ctx -> 'b ctx
end

module type Applicative = sig
  include Functor
  val (<*>) : ('a -> 'b) ctx -> 'a ctx -> 'b ctx
  val inject : 'a -> 'a ctx
end

module type Monad = sig
  include Applicative
  val (>>=) : 'a ctx -> ('a -> 'b ctx) -> 'b ctx
end

type ('s1, 's0, 't1, 't0) transform =
  ('s0 -> 's1) -> 't0 -> 't1

examples.ml

open Lens

let fmap_opt f o = match o with None -> None | Some x -> Some (f x)
let setif3 y x = match x with 3 -> Some y | _ -> None
let setif2 y x = match x with 2 -> Some y | _ -> None
let setif1 y x = match x with 1 -> Some y | _ -> None

let b1 =
    (lens_snd $* fmap_opt)
    (setif3 5) (4, 3)
         = Some (4, 5)

let b2 =
    (lens_snd $* fmap_opt)
    (setif2 5) (4, 3) = None

let b3 =
    (lens_fst @* lens_snd $* fmap_opt)
    (setif1 5) ((3, 1), (2, 4))
         = Some ((3, 5), (2, 4))

let b4 =
    (lens_fst @* lens_snd $* fmap_opt)
    (setif1 5) ((3, 2), (2, 4)) = None

let b5 =
    (lens_fst @* lens_snd @* lens_snd @* lens_fst $* fmap_opt)
    (setif1 5) ((2, (4, (3, 2))), (1, (((5, 6), (2, 1)), 3)))
         = None

let b6 =
    (lens_fst @* lens_snd @* lens_snd @* lens_fst $* fmap_opt)
    (setif3 5) ((2, (4, (3, 2))), (1, (((5, 6), (2, 1)), 3)))
         = Some ((2, (4, (5, 2))), (1, (((5, 6), (2, 1)), 3)))

let _ =
  assert (List.for_all (fun x -> x) [b1; b2; b3; b4; b5; b6]);
  print_endline "All assertions correct!";;

lens.ml

open Base

(** Lens *)

type ('b, 'a, 't, 's) lens = 's -> 'a * ('b -> 't)
type ('a, 's) lens' = ('a, 'a, 's, 's) lens

let lens f = f

let lens_id parent = parent, id

let lens_get lens = fst % lens

let lens_set lens = snd % lens

let (@*) lens0 lens1 old_x =
  let old_s, set0 = lens0 old_x in
  let old_a, set1 = lens1 old_s in
  old_a, set0 % set1

let ($*) lens fmap mkchild parent =
  let child, set = lens parent in
  fmap set (mkchild child)

let alongside_fst lens (l0, r0) =
  let child, set = lens l0 in
  (child, r0), first set

let alongside_snd lens (l0, r0) =
  let child, set = lens r0 in
  (l0, child), second set

let lens_fst (l0, r0) = l0, (fun l1 -> (l1, r0))

let lens_snd (l0, r0) = r0, (fun r1 -> (l0, r1))

module Lenses (F: Functor) = struct
  include F
  let (%%~) lens f = ($*) lens (<$>) f
end

(** Prisms *)

type ('b, 'a, 't, 's) prism = ('b -> 't) * ('s -> ('a, 't) result)
type ('a, 's) prism' = ('a, 'a, 's, 's) prism

let prism f = f

let prism_id = id, fun x -> Ok x

let prism_get_opt prs = opt_of_res % snd prs

let prism_set prs = const (fst prs)

(* not sure if this is a good idea... for now, it's not exposed *)
let invert prs =
  let bt, seta = prs in
  let sets a = Ok (bt a)  in
  let tb b = match seta b with
    | Ok t -> t
    | _ -> failwith "tried to set on an inverted prism" in
  tb, sets

let (@+) prs0 prs1 =
  let ty, sets = prs0 in
  let bt, seta = prs1 in
  let setxa x = match sets x with
    | Error y -> Error y
    | Ok s -> match seta s with
      | Error t -> Error (ty t)
      | Ok a -> Ok a in
  ty % bt, setxa

let ($+) prism fmap inject mkchild parent =
  let bt, seta = prism in
  map2_res inject (fmap bt) @@ map_res mkchild @@ seta parent

module Prisms (A: Applicative) = struct
  include A
  let (%%~) prism f = ($+) prism (<$>) inject f
end

(** Traversals. *)

(* this is not the most ideal representation; more ideally we would use a
   lazy list or "iterator" instead but ocaml has no standard such type :( *)
type ('b, 'a, 't, 's) traversal = 's -> 'a list * ('b list -> 't)
type ('a, 's) traversal' = ('a, 'a, 's, 's) traversal

let traversal f = f

let traversal_id parent = [parent], List.hd

let traversal_of_lens lens parent =
  let child, set = lens parent in
  [child], set % List.hd

let traversal_of_prism prism parent =
  let bt, seta = prism in
  match seta parent with
  | Error t -> [], const t
  | Ok a -> [a], bt % List.hd

let traversal_get_list traversal = fst % traversal

let traversal_set traversal s b =
  let alist, set = traversal s in
  set (List.map (const b) alist)

let (@::) trav0 trav1 old_x =
  let old_sl, set_sl = trav0 old_x in
  let rev_getsets = List.rev_map trav1 old_sl in
  let old_al_l = List.rev_map fst rev_getsets in
  let set_al = List.rev_map snd rev_getsets in
  let set new_al =
    (* given a reference list-of-lists, split the input list to have the same structure as it *)
    let rec partition input reference output = match input, reference with
      | [], [] -> List.rev_map List.rev output
      | [], _ | _, [] -> raise (Invalid_argument "traversal's setter was used inappropriately")
      | hd::tl, []::reftl -> partition input reftl ([]::output)
      | hd::tl, refhd::reftl -> partition tl reftl ((hd::(List.hd output))::(List.tl output))
    in
    let new_al_l = partition new_al old_al_l [] in
    let new_sl = List.rev (List.rev_map2 (|>) new_al_l set_al) in
    set_sl new_sl in
  List.concat old_al_l, set

let ($::) traversal fmap sequence mkchild parent0 =
  let children, set = traversal parent0 in
  let newchildren = List.rev (List.rev_map mkchild children) in
  let wrapped = sequence newchildren in
  fmap set wrapped

module Traversals (A: Applicative) = struct
  include A

  let rec sequence = function
    | [] -> inject []
    | hd::tl -> List.cons <$> hd <*> sequence tl

  let (%%~) traversal f = ($::) traversal (<$>) sequence f
end

lens.mli

(** Lens and traversals, with or without ocaml modules/functors. *)

open Base

(** {2 Lens} *)

(** Lens type.

    A lens allows us to operate on one child of a given parent data structure.
    If implemented well, it does this efficiently for large or deep structures,
    avoiding traversing the parent twice even when (e.g.) setting is only
    desired conditionally.
*)
type ('b, 'a, 't, 's) lens

(** Less-polymorphic version of {!lens}.

    The old and new types of child values are the same, and likewise with
    the old and new types of parent values.
*)
type ('a, 's) lens' = ('a, 'a, 's, 's) lens

(**
    This takes a parent value and returns a (child value, setter) pair, where
    the setter is a closure that is closed over the input parent - thereby
    giving us the "traverse-only-once" semantics.
*)
val lens : ('s -> 'a * ('b -> 't)) -> ('b, 'a, 't, 's) lens

(** Identity lens, the child is the parent. *)
val lens_id : ('a, 'a) lens'

(** Turn a lens into a getter function. *)
val lens_get : ('b, 'a, 't, 's) lens -> 's -> 'a

(** Turn a lens into a setter function. *)
val lens_set : ('b, 'a, 't, 's) lens -> 's -> 'b -> 't

(** Compose two lens. The inner lens is on the right.

    To compose other types, reify them first using {!($:)}, {!($^:)} or {!($*:)}
    to get two {!transform}s then compose these using normal function
    composition, which we provide as the {!(%)} operator.

    (In the future we might support composing different things directly.)
*)
val (@*) :
  ('t, 's, 'y, 'x) lens ->
  ('b, 'a, 't, 's) lens ->
  ('b, 'a, 'y, 'x) lens

(** Reify a lens, allowing you to use it to apply a function to a parent value.

    The first argument is a functor [fmap] function. This takes two arguments:
    the first argument is an efficient "setter" function that is supplied by the
    lens, and the second argument is an "intermediate functor" as described
    later; it returns a functor over some-or-none new-parent ['t] value(s). (The
    setter function itself takes one argument, a new-child ['b] value, and
    returns a new parent ['t] value based on the old parent ['s] value that was
    previously-input as the third argument, see below.)

    Once reified, the lens becomes a {!transform} which can be composed directly
    via functional composition (which we provide as the {!(%)} operator) just
    like Haskell's [Lens]es and [Traversal]s can.

    To use the reified lens, you give it two further arguments: the first is the
    function you want to execute on a parent value, which takes one argument,
    the ['a] value of a single old child, and returns a functor/context over
    some-or-none new child ['b] value(s); this is used as the basis for any new
    parent ['t] value(s). The second argument (to the reified lens) is a single
    input parent ['s] value to execute the first argument on, via the lens. The
    output is a functor/context over some-or-none new parent ['t] value(s).

    (A functor is a container/context over some-or-none inner value(s), that
    allows a function to be applied to the values via its [fmap] function.)

    "Which child or children" to get/set is fixed for a given lens. To get/set
    different child or children, use a different lens.

    For more details and examples, see the Haskell Lens tutorial. Note that in
    Haskell the first argument [fmap] is taken from the environment and does not
    need to be supplied explicitly.
*)
val ($*) :
  ('b, 'a, 't, 's) lens ->
  (('b -> 't) -> 'b_ctx -> 't_ctx) ->
  ('a -> 'b_ctx) -> 's -> 't_ctx

(** Transform a lens to operate on the first element of a pair.

    Users of the lens are able to update the second element directly.
*)
val alongside_fst : ('b, 'a, 't, 's) lens ->
  (('b * 'r), ('a * 'r), ('t * 'r), ('s * 'r)) lens

(** Transform a lens to operate on the second element of a pair.

    Users of the lens are able to update the first element directly.
*)
val alongside_snd : ('b, 'a, 't, 's) lens ->
  (('l * 'b), ('l * 'a), ('l * 't), ('l * 's)) lens

(** A lens that operates only on the first element of a pair.

    The lens never touches the second element; it is always preserved. If your
    use-case involves updating the second element (e.g. as part of the return
    value of a state transition) then you probably can't use this lens. You
    might have better luck using {!alongside_fst} instead.
*)
val lens_fst : ('b, 'a, ('b * 'r), ('a * 'r)) lens

(** A lens that operates only on the second element of a pair.

    The lens never touches the first element; it is always preserved. If your
    use-case involves updating the first element (e.g. as part of the return
    value of a state transition) then you probably can't use this lens. You
    might have better luck using {!alongside_snd} instead.
*)
val lens_snd : ('b, 'a, ('l * 'b), ('l * 'a)) lens

module Lenses : functor (F: Functor) -> sig
  include Functor
  val (%%~) :
    ('b, 'a, 't, 's) lens ->
    ('a -> 'b ctx) -> 's -> 't ctx
end

(** {2 Prisms} *)

type ('b, 'a, 't, 's) prism

type ('a, 's) prism' = ('a, 'a, 's, 's) prism

(** Create a new prism.

    A prism is like a lens where the child may or may not exist in the parent.
    In other words, it is like a lens that operates on a sum (variant) type
    rather than a product (record) type.

    The first part is a function that transforms a ['b] new child value into a
    ['t] new parent value. The second part is a function that checks the ['s]
    old parent value to see if the child exists, and returns either [Ok a] where
    [a] is a ['a] old child value, or [Error t] where [t] is the old parent
    value with its type changed from ['s] into ['t].

    See https://artyom.me/lens-over-tea-5 for an explanation of how ['s] gets
    magically turned into a ['t].
*)
val prism : ('b -> 't) * ('s -> ('a, 't) result) ->
  ('b, 'a, 't, 's) prism

(** Identity prism, the child is the parent. *)
val prism_id : ('a, 'a) prism'

(** Turn a traversal into a getter function. *)
val prism_get_opt : ('b, 'a, 't, 's) prism -> 's -> 'a option

(** Turn a traversal into a setter function. *)
val prism_set : ('b, 'a, 't, 's) prism -> 's -> 'b -> 't

(** Compose two prisms. The inner prism is on the right.

    To compose other types, reify them first using {!($:)}, {!($^:)} or {!($*:)}
    to get two {!transform}s then compose these using normal function
    composition, which we provide as the {!(%)} operator.

    (In the future we might support composing different things directly.)
*)
val (@+) :
  ('t, 's, 'y, 'x) prism ->
  ('b, 'a, 't, 's) prism ->
  ('b, 'a, 'y, 'x) prism

(** Reify a prism.

    To use the reified prism, you give it two further arguments, similar to how
    reified lens works (see {!($:)}). But the behaviour is slightly different:
    if the child does not exist in the parent, then the old value (with the new
    type) is returned, rather than executing the transform (i.e. rather than
    applying the ['a -> 'fb] function). If it does exist, then the transform is
    applied and the first part of the prism (see {!prism}) is applied to change
    the ['fb] into an ['ft] which is returned as the result of the transform.
*)
val ($+) :
  ('b, 'a, 't, 's) prism ->
  (('b -> 't) -> 'fb -> 'ft) ->
  ('t -> 'ft) ->
  ('a -> 'fb) -> 's -> 'ft

module Prisms : functor (A: Applicative) -> sig
  include Applicative
  val (%%~) :
    ('b, 'a, 't, 's) prism ->
    ('a -> 'b ctx) -> 's -> 't ctx
end

(** {2 Traversals} *)

type ('b, 'a, 't, 's) traversal

type ('a, 's) traversal' = ('a, 'a, 's, 's) traversal

(** Create a new traversal.

    A traversal is like a lens or prism that may have 0, 1 or more children.
*)
val traversal : ('s -> 'a list * ('b list -> 't)) -> ('b, 'a, 't, 's) traversal

(** Create a traversal from a lens, traversing the one child of the lens.

    Note that we don't provide a [lens_of_traversal] function because that is
    not generally safe to do; TODO: explain why.
*)
val traversal_of_lens : ('b, 'a, 't, 's) lens -> ('b, 'a, 't, 's) traversal

(** Create a traversal from a prism, over the one-or-none child of the prism.

    Note that we don't provide a [prism_of_traversal] function because that is
    not generally safe to do; TODO: explain why.
*)
val traversal_of_prism : ('b, 'a, 't, 's) prism -> ('b, 'a, 't, 's) traversal

(** Identity traversal, the child is the parent. *)
val traversal_id : ('a, 'a) traversal'

(** Turn a traversal into a getter function. *)
val traversal_get_list : ('b, 'a, 't, 's) traversal -> 's -> 'a list

(** Turn a traversal into a setter function. *)
val traversal_set : ('b, 'a, 't, 's) traversal -> 's -> 'b -> 't

(** Compose two traversals. The inner traversal is on the right.

    To compose other types, reify them first using {!($:)}, {!($^:)} or {!($*:)}
    to get two {!transform}s then compose these using normal function
    composition, which we provide as the {!(%)} operator.

    (In the future we might support composing different things directly.)
*)
val (@::) :
  ('t, 's, 'y, 'x) traversal ->
  ('b, 'a, 't, 's) traversal ->
  ('b, 'a, 'y, 'x) traversal

(** Reify a traversal. *)
val ($::) :
  ('b, 'a, 't, 's) traversal ->
  (('b list -> 't) -> 'b_list_ctx -> 't_ctx) ->
  ('b_ctx list -> 'b_list_ctx) ->
  ('a -> 'b_ctx) -> 's -> 't_ctx

module Traversals : functor (A: Applicative) -> sig
  include Applicative
  val sequence : 'a ctx list -> 'a list ctx
  val (%%~) :
    ('b, 'a, 't, 's) traversal ->
    ('a -> 'b ctx) -> 's -> 't ctx
end

Makefile

all:
	ocamlc base.ml lens.mli lens.ml examples.ml

clean:
	rm -f *.cm* a.out

http://yi-editor.blogspot.com/2008/12/prototypes-encoding-oo-style.html