An implementation of “programmed laziness” for list concatenation

catlist.ml

module CatList : sig

  (** “Lazy” lists with O(1) concatenation. *)
  type +'a t

  type (+'a, +'l) view =
    | Nil
    | Cons of 'a * 'l

  val view : 'a t -> ('a, 'a t) view

  (** {0 Smart constructors} *)
  val nil : 'a t
  val cons : 'a -> 'a t -> 'a t

  (** {0 Concatenation} *)
  val append : front:'a t -> back:'a t -> 'a t

end = struct

  type (+'a, +'l) view =
    | Nil
    | Cons of 'a * 'l

  type +'a t = { view' : unit -> ('a, 'a t) view; peek : unit -> 'a node }
    (* Note: instead of just representing `'a t` as a `'a node ref`,
       we expose the internals as functions, so that the type
       parameter can be covariant. This complicates the presentation
       a little, but if we don't, then `nil` can't be defined. *)

  and +'a node =
    | Forced of ('a, 'a t) view
    | Suspended of { front : 'a t; back : 'a t}
  (* When calling `append`, we initially form a `Suspended` node,
     where we explicitly keep the arguments of the append. We will
     execute the append lazily. A list where all the pending appends
     have been executed at least down its tail will be represented as
     a `Forced`. *)

  (** {0 Pattern matching} *)

  let view : 'a. 'a t -> ('a, 'a t) view = fun { view' } ->
    view' ()

  (** {0 Internal stuff} *)

  let rec app_view : 'a. front:('a, 'a t) view -> back:'a t -> ('a, 'a t) view = fun ~front ~back ->
    match front with
    | Nil -> view back
    | Cons (x, l) -> Cons (x, append ~front:l ~back)
  and app_node : 'a. front:'a node -> back:'a t -> ('a, 'a t) view = fun ~front ~back ->
    match front with
    | Forced front -> app_view ~front ~back
    | Suspended { front; back=middle } -> force ~front ~back:(append ~front:middle ~back)
  and force_ref : 'a. front:'a node ref -> back:'a t -> ('a, 'a t) view = fun ~front ~back ->
    app_node ~front:(!front) ~back
  and force : 'a. front:'a t -> back:'a t -> ('a, 'a t) view = fun ~front ~back ->
    app_node ~front:(front.peek ()) ~back
    (* This is where the magic happens: instead of blindly forcing the
       front node with `view`, like built-in laziness would do, we can
       inspect the front node. If it's already a suspended append,
       then we fuse the two appends together. As a consequence, next
       time the list is forced, they can be pushed together as a
       single step.

       Effectively, this changes an inefficient `(…(xs1 ++ xs2) ++ …)
       ++ xsn)` into the more efficient `x1 ++ (x2 ++ (… ++
       (xn)…))`.*)
  and view_ref : 'a. 'a node ref -> ('a, 'a t) view = fun l ->
    match !l with
    | Forced view -> view
    | Suspended { front; back } ->
       let view = force ~front ~back in
       let () = l := Forced view in
       view
  and make : 'a. 'a node -> 'a t = fun x ->
    let thunk = ref x in
    { view' = (fun () -> view_ref thunk); peek = fun () -> !thunk }
  and append : 'a. front:'a t -> back:'a t -> 'a t = fun ~front ~back ->
    make @@ Suspended { front; back }

  (** {0 Smart constructors} *)

  let nil : 'a. 'a t =
    make @@ Forced Nil

  let cons : 'a. 'a -> 'a t -> 'a t = fun x l ->
    make @@ Forced (Cons (x, l))

end