enclosure.ml

type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t

external is_a_sub :
  ('a, 'b) bigarray -> int ->
  ('a, 'b) bigarray -> int -> bool = "caml_bigarray_is_a_sub" [@@noalloc]
external bigarray_physically_equal :
  ('a, 'b) bigarray ->
  ('a, 'b) bigarray -> bool = "caml_bigarray_physically_equal" [@@noalloc]

[@@@warning "-32"]

module type V = sig
  type t

  val pp : t Fmt.t
  val sentinel : t
  val weight : t -> int
  val merge : t -> t -> t option
  val physically_equal : t -> t -> bool
end

module RBQ (V : V) = struct
  module Queue = Ke.Fke.Weighted

  type t = {a: V.t array; c: int; m: int; q: (int, Bigarray.int_elt) Queue.t}
  (* XXX(dinosaure): [ke] is limited to [Bigarray.kind]. We make an [array]
     which will contain values and [q] will contain index of them. Length of [a]
     is length of [q]. By this way, length is a power of two and [a] follows
     same assertions (see [mask]) as [Ke].

     [c] will be the cursor in [a]. [m] is the capacity. It's a good example of
     [ke] with something else than [Bigarray.kind]. *)

  let make capacity =
    let q, capacity = Queue.create ~capacity Bigarray.Int in
    { a= Array.make capacity V.sentinel
    ; c= 0
    ; m= capacity
    ; q }

  let pp ppf t =
    Fmt.pf ppf "{ @[<hov>a = %a;@ \
                         c = %d;@ \
                         m = %d;@ \
                         q = %a;@] }"
      Fmt.(Dump.array V.pp) t.a
      t.c t.m
      (Queue.dump Fmt.int) t.q

  let available t = Queue.available t.q

  let[@inline always] mask x t = x land (t.m - 1)

  let push t v =
    let i = mask t.c t in
    match Queue.push t.q i with
    | Some q ->
      t.a.(i) <- v ;
      Ok { t with c= succ t.c; q; }
    | None -> Error t

  let shift_exn t =
    let i, q = Queue.pop_exn t.q in
    (t.a.(i), { t with q })

  let cons t v =
    let i = mask t.c t in
    match Queue.cons t.q i with
    | Some q ->
      t.a.(i) <- v ;
      Ok { t with c= succ t.c; q; }
    | None -> Error t

  exception Full

  let cons_exn t v =
    match cons t v with
    | Ok t -> t
    | Error _ -> raise Full

  let weight t =
    Queue.fold (fun a i -> a + V.weight t.a.(i)) 0 t.q

  let to_list t =
    let res = ref [] in
    Queue.rev_iter (fun i -> res := t.a.(i) :: !res) t.q ;
    !res
end

module RBA = Ke.Fke.Weighted

module Buffer = struct
  type t =
    | Bigstring of Bigstringaf.t
    | String of string
    | Bytes of bytes

  let weight = function
    | Bigstring x -> Bigstringaf.length x
    | String x -> String.length x
    | Bytes x -> Bytes.length x

  let sub buffer off len = match buffer with
    | Bigstring x -> Bigstring (Bigstringaf.sub x ~off ~len)
    | String x -> String (String.sub x off len)
    | Bytes x -> Bytes (Bytes.sub x off len)
end

module IOVec = struct
  type t = {buffer: Buffer.t; off: int; len: int}

  let weight {len; _} = len

  let pp _ _ = assert false

  let sentinel =
    let deadbeef = "\222\173\190\239" in
    {buffer= Buffer.String deadbeef; off= 0; len= String.length deadbeef}

  let make buffer off len =
    {buffer; off; len}

  let length {len; _} = len

  let lengthv = List.fold_left (fun a x -> length x + a) 0

  let shift {buffer; off; len} n =
    assert (n <= len) ;
    {buffer; off= off + n; len= len - n}

  let split {buffer; off; len} n =
    assert (n <= len) ;
    ( {buffer= Buffer.sub buffer off n; off= 0; len= n}
    , {buffer= Buffer.sub buffer (off + n) (len - n); off= 0; len= len - n})

  let physically_equal a b =
    match a, b with
    | {buffer= Buffer.Bytes a; _}, {buffer= Buffer.Bytes b; _} -> a == b
    | {buffer= Buffer.Bigstring a; _}, {buffer= Buffer.Bigstring b; _} -> bigarray_physically_equal a b
    | _, _ -> false

  let merge a b =
    match a, b with
    | {buffer= Buffer.Bytes a'; _}, {buffer= Buffer.Bytes b'; _} ->
      assert (a' == b') ;
      if a.off + a.len = b.off
      then Some {buffer= Buffer.Bytes a'; off= a.off; len= a.len + b.len}
      else None
    | {buffer= Buffer.Bigstring a'; _}, {buffer= Buffer.Bigstring b'; _} ->
      assert (bigarray_physically_equal a' b') ;
      if a.off + a.len = b.off
      then Some {buffer= Buffer.Bigstring a'; off= a.off; len= a.len + b.len}
      else None
    | _, _ -> None
end

module RBS = RBQ (IOVec)

type encoder =
  { sched : RBS.t
  ; write : (char, Bigarray.int8_unsigned_elt) RBA.t
  ; flush : (int * (int -> encoder -> unit)) Ke.Fke.t
  ; written : int
  ; received : int }

(* XXX(dinosaure): [sched] is a queue of [IOVec]. [write] is a
   ring-buffer/[Bigstringaf.t]. [flush] is a queue which can contain
   user-defined operation at a break point. [written] is how many bytes we
   sended to the user (afterwards a *flush* operation). [received] is how many
   bytes we received from the user.

   The goal is to have two ways to fill output:
   - an heavy way with [write_*] operations which will do internally a [blit].
   - a soft way with [shedule_*] operations which will store a pointer.

   The complexity is under [sched] where it stores pointer from user but pointer
   from [write] queue too. Indeed, [write_] operations did not do only a [blit]
   but then they store resulted/*blitted* [Bigstringaf.t] part to [sched].

   When we want to shift a part of [encoder], **all** buffers are stored in
   [sched]. So we need to shift [sched]. However, resulted [IOVec] can be
   physically a part of [write]. In this context, we need to shift [write]. *)

type 'v state =
  | Flush of {continue : int -> 'v state; iovecs : IOVec.t list}
  | Continue of {continue : encoder -> 'v state; encoder: encoder}
  | End of 'v

type 'r k0 = (encoder -> 'r state) -> encoder -> 'r state
type ('a, 'r) k1 = 'a -> (encoder -> 'r state) -> encoder -> 'r state

let create len =
  let write, _ = RBA.create ~capacity:len Bigarray.Char in
  { sched= RBS.make (len * 2)
  ; write
  ; flush = Ke.Fke.empty
  ; written= 0
  ; received= 0 }

let check iovec {write; _} =
  match iovec with
  | {IOVec.buffer= Buffer.Bigstring x; _} ->
    let buf = RBA.unsafe_bigarray write in
    let len = Bigarray.Array1.dim buf in
    is_a_sub x (Bigarray.Array1.dim x) buf len
  | _ -> false

let shift_buffers written t =
  let rec go written acc t =
    match RBS.shift_exn t.sched with
    | iovec, shifted ->
      let len = IOVec.length iovec in
      if written > len
      then go (written - len) (iovec :: acc)
          { t with sched= shifted
                 ; write=
                     if check iovec t
                     then RBA.N.shift_exn t.write len
                     else t.write }
      else if written > 0
      then
        let last, rest = IOVec.split iovec written in
        ( List.rev (last :: acc)
        , { t with sched= RBS.cons_exn shifted rest
                 ; write=
                     if check iovec t
                     then RBA.N.shift_exn t.write (IOVec.length last)
                     else t.write })
      else (List.rev acc, t)
    | exception RBS.Queue.Empty -> (List.rev acc, t) in
  go written [] t

let shift_flushes written t =
  let rec go t =
    try
      let (threshold, f), flush = Ke.Fke.pop_exn t.flush in
      if compare (t.written + written - min_int) (threshold - min_int) >= 0
      then let () = f written {t with flush} in go {t with flush}
      else t
    with Ke.Fke.Empty -> t in
  go t

let shift n t =
  let lst, t = shift_buffers n t in
  ( lst
  , let t = shift_flushes (IOVec.lengthv lst) t in { t with written = t.written + n} )

let has t = RBS.weight t.sched

let drain drain t =
  let rec go rest t =
    match RBS.shift_exn t.sched with
    | iovec, shifted ->
        let len = IOVec.length iovec in
        if rest > len then
          go (rest - len)
            { t with
              sched= shifted
            ; write=
                if check iovec t
                then RBA.N.shift_exn t.write len
                else t.write }
        else
          { t with
            sched= RBS.cons_exn shifted (IOVec.shift iovec rest)
          ; write=
              if check iovec t
              then RBA.N.shift_exn t.write rest
              else t.write }
    | exception RBS.Queue.Empty -> t in
  let t = go drain t in { t with written= t.written + drain }

let flush k t =
  let t = shift_flushes (has t) t in
  let continue n =
    let t = drain n t in
    k {t with written= t.written + n} in
  Flush {continue; iovecs= RBS.to_list t.sched}

let continue continue encoder = Continue {continue; encoder}

let rec schedule k ~length ~buffer ?(off = 0) ?len v t =
  let len = match len with Some len -> len | None -> length v - off in
  match RBS.push t.sched (IOVec.make (buffer v) off len) with
  | Ok sched ->
    (* TODO: merge [Bigstringaf.t]. *)
    continue k {t with sched; received= t.received + len}
  | Error _ ->
      let max = RBS.available t.sched in
      let k t =
        (schedule [@tailcall]) k ~length ~buffer ~off:(off + max)
          ~len:(len - max) v t
      in
      schedule (flush k) ~length ~buffer ~off ~len:max v t

let schedule_string =
  let length = String.length in
  let buffer x = Buffer.String x in
  fun k t ?(off = 0) ?len v -> schedule k ~length ~buffer ~off ?len v t

let schedule_bytes =
  let length = Bytes.length in
  let buffer x = Buffer.Bytes x in
  fun k t ?(off = 0) ?len v -> schedule k ~length ~buffer ~off ?len v t

let schedule_bigstring =
  let length = Bigarray.Array1.dim in
  let buffer x = Buffer.Bigstring x in
  fun k t ?(off = 0) ?len v -> schedule k ~length ~buffer ~off ?len v t

let schedule_flush f t = {t with flush= Ke.Fke.push t.flush (t.received, f)}

external identity : 'a -> 'a = "%identity"

let schedulev k l t =
  let rec go t = function
    | [] -> continue k t
    | (length, off, len, buffer) :: r ->
      schedule
        (fun t -> (go [@tailcall]) t r)
        ~length ?off ?len ~buffer:identity buffer t
  in go t l

let schedulev_bigstring k l t =
  let rec go t = function
    | [] -> continue k t
    | buffer :: r ->
      schedule_bigstring (fun t -> (go [@tailcall]) t r) t buffer
  in go t l

let rec write k ~blit ~length ?(off = 0) ?len buffer t =
  let len = match len with Some len -> len | None -> length buffer - off in
  let available = RBA.available t.write in
  (* XXX(dinosaure): we can factorize the first and the second branch. *)
  if available >= len then
    let areas, write = RBA.N.push_exn t.write ~blit ~length ~off ~len buffer in
    schedulev_bigstring k areas {t with write}
  else if available > 0 then
    let k t =
      (write [@tailcall]) k ~blit ~length ~off:(off + available)
        ~len:(len - available) buffer t in
    let areas, write = RBA.N.push_exn t.write ~blit ~length ~off ~len:available buffer in
    schedulev_bigstring (flush k) areas {t with write}
  else
    let k t = (write [@tailcall]) k ~blit ~length ~off ~len buffer t in
    flush k t

let writev k l t =
  let rec go t = function
    | [] -> continue k t
    | (blit, length, off, len, buffer) :: r ->
        write (fun t -> (go [@tailcall]) t r) ~blit ~length ?off ?len buffer t
  in go t l

let bigarray_blit_from_string src src_off dst dst_off len =
  Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len

let bigarray_blit_from_bytes src src_off dst dst_off len =
  Bigstringaf.blit_from_bytes src ~src_off dst ~dst_off ~len

let bigarray_blit src src_off dst dst_off len =
  Bigarray.Array1.(blit (sub src src_off len) (sub dst dst_off len))

let bigarray_blit_to_bytes src src_off dst dst_off len =
  Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len

let write_string =
  let length = String.length in
  let blit = bigarray_blit_from_string in
  fun ?(off = 0) ?len a k t -> write k ~blit ~length ~off ?len a t

let write_bytes =
  let length = Bytes.length in
  let blit = bigarray_blit_from_bytes in
  fun ?(off = 0) ?len a k t -> write k ~blit ~length ~off ?len a t

let write_bigstring =
  let length = Bigarray.Array1.dim in
  let blit = bigarray_blit in
  fun ?(off = 0) ?len a k t -> write k ~blit ~length ~off ?len a t

let write_char =
  let length _ = assert false in
  let blit src src_off dst dst_off len =
    assert (src_off = 0) ;
    assert (len = 1) ;
    Bigstringaf.set dst dst_off src
  in
  fun a k t -> write k ~length ~blit ~off:0 ~len:1 a t

let write_uint8 =
  let length _ = assert false in
  let blit src src_off dst dst_off len =
    assert (src_off = 0) ;
    assert (len = 1) ;
    Bigstringaf.set dst dst_off (Char.unsafe_chr src)
  in
  fun a k t -> write k ~length ~blit ~off:0 ~len:1 a t

module type S = sig
  val write_uint16 : int -> (encoder -> 'v state) -> encoder -> 'v state
  val write_uint32 : int32 -> (encoder -> 'v state) -> encoder -> 'v state
  val write_uint64 : int64 -> (encoder -> 'v state) -> encoder -> 'v state
end

module type ENDIAN = sig
  type t = Bigstringaf.t

  val set_int16 : t -> int -> int -> unit
  val set_int32 : t -> int -> int32 -> unit
  val set_int64 : t -> int -> int64 -> unit
end

module Make (X : ENDIAN) : S = struct
  let _length _ = assert false

  let write_uint16 =
    let length = _length in
    let blit src src_off dst dst_off len =
      assert (src_off = 0) ;
      assert (len = 2) ;
      X.set_int16 dst dst_off src
    in
    fun a k t -> write k ~length ~blit ~off:0 ~len:2 a t

  let write_uint32 =
    let length = _length in
    let blit src src_off dst dst_off len =
      assert (src_off = 0) ;
      assert (len = 4) ;
      X.set_int32 dst dst_off src
    in
    fun a k t -> write k ~length ~blit ~off:0 ~len:4 a t

  let write_uint64 =
    let length = _length in
    let blit src src_off dst dst_off len =
      assert (src_off = 0) ;
      assert (len = 8) ;
      X.set_int64 dst dst_off src
    in
    fun a k t -> write k ~length ~blit ~off:0 ~len:8 a t
end

module LE' = struct
  type t = Bigstringaf.t

  let set_int16 = Bigstringaf.set_int16_le
  let set_int32 = Bigstringaf.set_int32_le
  let set_int64 = Bigstringaf.set_int64_le
end

module BE' = struct
  type t = Bigstringaf.t

  let set_int16 = Bigstringaf.set_int16_be
  let set_int32 = Bigstringaf.set_int32_be
  let set_int64 = Bigstringaf.set_int64_be
end

module LE = Make(LE')
module BE = Make(BE')

format.ml

module type FUNCTOR = sig type 'a t end

type (+'a, 't) app

module type X = sig
  type 'a s
  type t

  external inj : 'a s -> ('a, t) app = "%identity"
  external prj : ('a, t) app -> 'a s = "%identity"
end

module Common = struct
  type t

  external inj : 'a -> 'b = "%identity"
  external prj : 'a -> 'b = "%identity"
end

module Make (T : FUNCTOR) : X with type 'a s = 'a T.t = struct
  type 'a s = 'a T.t
  include Common
end

module State = Make(struct type 'a t = 'a Enclosure.state end)

type ('a, 'r) encoding = (Pretty.t -> 'r) -> Pretty.t -> 'a -> 'r
type 'r k = (Pretty.t -> 'r) -> Pretty.t -> 'r

let ( <.> ) f g = fun x -> f (g x)

let char
  : (char, 'r) encoding
  = fun k t chr ->
    (* XXX(dinosaure): use [Enclosure.write_char], TODO! *)
    let atom =
      Pretty.(Value { breakable= false
                    ; value= String ({ off= 0; len= 1; }, String.make 1 chr); }) in
    State.inj (Pretty.push (State.prj <.> k) atom t)

let using : ('f -> 't) -> ('t, _) encoding -> ('f, _) encoding =
  fun f e k t x -> e k t (f x)

let string
  : ?breakable:bool -> (string, _) encoding
  = fun ?(breakable= false) k t x ->
    let atom =
      Pretty.(Value { breakable
                    ; value= String ({ off= 0; len= String.length x; }, x); }) in
    State.inj (Pretty.push (State.prj <.> k) atom t)

let bytes
  : ?breakable:bool -> (bytes, _) encoding
  = fun ?(breakable= false) k t x ->
    let atom =
      Pretty.(Value { breakable
                    ; value= Bytes ({ off= 0; len= Bytes.length x; }, x); }) in
    State.inj (Pretty.push (State.prj <.> k) atom t)

let new_line : _ k
  = fun k t -> State.inj (Pretty.push (State.prj <.> k) Pretty.New_line t)

let box : _ k
  = fun k t -> State.inj (Pretty.push (State.prj <.> k) Pretty.(Open Box) t)

let tbox : (int, _) encoding = fun k t indent ->
  State.inj (Pretty.push (State.prj <.> k) Pretty.(Open (TBox indent)) t)
let bbox : _ k = fun k t -> State.inj (Pretty.push (State.prj <.> k) Pretty.(Open BBox) t)
let close : _ k = fun k t -> State.inj (Pretty.push (State.prj <.> k) Pretty.Close t)

type ('ty, 'v) t =
  | Const : ('a, ('v, State.t) app) encoding * 'a -> (('v, State.t) app, 'v) t
  | Atom : ('a, ('v, State.t) app) encoding -> ('a -> ('v, State.t) app, 'v) t
  | Param : (('a, ('v, State.t) app) encoding -> 'a -> ('v, State.t) app, 'v) t
  | New_line : (('v, State.t) app, 'v) t
  | Open : Pretty.box -> (('v, State.t) app, 'v) t
  | Close : (('v, State.t) app, 'v) t

let atom encoding = Atom encoding
let const encoding x = Const (encoding, x)

let keval_order
  : type ty v. Pretty.t -> (ty, v) t -> (Pretty.t -> (v, State.t) app) -> ty
  = fun t order k -> match order with
    | Const (encoding, v) ->
      encoding k t v
    | Param -> fun encoding v ->
      encoding k t v
    | Atom encoding -> fun v ->
      encoding k t v
    | New_line ->
      new_line k t
    | Open box ->
      let atom = Pretty.Open box in
      State.inj (Pretty.push (State.prj <.> k) atom t)
    | Close ->
      close k t

let ( !! ) = atom
let ( $ ) = const
let new_line = New_line

type ('ty, 'v) fmt =
  | [] : (('v, State.t) app, ('v, State.t) app) fmt
  | (::) : ('x, 'v) t * (('v, State.t) app, ('r, State.t) app) fmt -> ('x, ('r, State.t) app) fmt

let rec keval : type ty v. Pretty.t -> (Pretty.t -> v) -> (ty, v) fmt -> ty =
 fun t k fmt -> match fmt with
   | [] -> k t
   | x :: r ->
     let k = fun t -> keval t k r in
     keval_order t x k

let field
  : _ -> _ -> string -> string -> _
  = fun t k -> keval t k [ string $ ">" ; !!string; string $ ":"; new_line; !!string; new_line ]

pretty.ml

type vec = { off: int; len: int; }
type box = Box | TBox of int | BBox

type value =
  | String of vec * string
  | Bytes of vec * bytes
  | Bigstring of vec * Bigstringaf.t

let split_value len = function
  | String (vec, v) ->
    let v0 = String.sub v 0 len in
    let v1 = String.sub v len (vec.len - len) in
    String ({ off= 0; len; }, v0), String ({ off= 0; len= vec.len - len }, v1)
  | Bytes (vec, v) ->
    let v0 = Bytes.sub v 0 len in
    let v1 = Bytes.sub v len (vec.len - len) in
    Bytes ({ off= 0; len; }, v0), Bytes ({ off= 0; len= vec.len - len}, v1)
  | Bigstring (vec, v) ->
    Bigstring ({ off= vec.off; len}, v), Bigstring ({ off= vec.off + len; len= vec.len - len }, v)

let length_of_value = function
  | String (vec, _) | Bytes (vec, _) | Bigstring (vec, _) -> vec.len

type atom =
  | Value of { breakable : bool; value : value; }
  | Break of { len : int; indent : int; }
  | New_line
  | Open of box
  | Close

type token =
  | TValue of value
  | TBreak of int

let length_of_token = function
  | TValue (String (vec, _)) -> vec.len
  | TValue (Bytes (vec,_ )) -> vec.len
  | TValue (Bigstring (vec, _)) -> vec.len
  | TBreak len -> len

module Option = struct
  type +'a t = 'a option

  let bind x f = match x with
    | Some x -> f x
    | None -> None

  let map f = function
    | Some x -> Some (f x)
    | None -> None

  let ( >>= ) = bind
  let ( >>| ) x f = map f x

  let value ~default = function
    | Some x -> x
    | None -> default
end

module Stack : sig
  type +'a t

  val empty : _ t
  val push : 'a -> 'a t -> 'a t
  val pop : 'a t -> ('a * 'a t) option
  val pop_exn : 'a t -> 'a * 'a t
  val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
  val tail_exn : 'a t -> 'a t
  val tail : 'a t -> 'a t option
  val map : ('a -> 'b) -> 'a t -> 'b t
end = struct
  type 'a t = 'a list

  let empty = []
  let push x t = x :: t

  exception Empty

  let pop_exn = function
    | [] -> raise Empty
    | x :: r -> x, r

  let pop = function
    | [] -> None
    | x :: r -> Some (x, r)

  let fold = List.fold_left

  let tail_exn = function
    | _ :: r -> r
    | [] -> raise Empty

  let tail = function
    | _ :: r -> Some r
    | [] -> None

  let map f l = List.map f l
end

module Queue = Ke.Fke

type t =
  { boxes : [ `Root | `Box | `Indent of int ] Stack.t
  ; breaks : [ `Indent of int ] Stack.t
  ; inner : int list Stack.t
  ; indent : int
  ; margin : int
  ; new_line : string
  ; queue : token Queue.t
  ; encoder : Enclosure.encoder }

let ( <.> ) f g = fun x -> f (g x)
let flip f = fun a b -> f b a

let merge_breaks token (queue, x) = match token, x with
  | Break { len= len_x; _ }, TBreak len  ->
    Some (queue, len_x + len)
  | _, _ -> None

let current_length_of_line t =
  t.indent + Queue.fold (flip ((+) <.> length_of_token)) 0 t.queue

let fold_breaks queue break =
  match Queue.tail queue with
  | Some (queue, TBreak _) -> Queue.push queue break
  | Some _ -> Queue.push queue break
  | None -> Queue.push Queue.empty break

let emit_line k t =
  let rec go queue encoder = match Queue.pop queue with
    | Some (TValue (String ({ off; len; }, v)), queue) ->
      Enclosure.schedule_string (go queue) encoder ~off ~len v
    | Some (TValue (Bytes ({ off; len; }, v)), queue) ->
      Enclosure.schedule_bytes (go queue) encoder ~off ~len v
    | Some (TValue (Bigstring ({ off; len; }, v)), queue) ->
      Enclosure.schedule_bigstring (go queue) encoder ~off ~len v
    | Some (TBreak len, queue) ->
      Enclosure.schedule_string (go queue) encoder ~len (String.make len ' ')
    | None ->
      let k encoder = k { t with encoder; queue= Queue.empty } in
      let k encoder = Enclosure.flush k encoder in
      Enclosure.schedule_string k encoder t.new_line in
  go t.queue t.encoder

let merge_indents k t =
  let indent_by_box = Stack.fold (fun a -> function `Box | `Root -> a | `Indent n -> a + n) 0 t.boxes in
  let indent_by_break = Stack.fold (fun a -> function `Indent n -> (max : int -> int -> int) a n) 0 t.breaks in
  k { t with indent= indent_by_box + indent_by_break
           ; breaks= Stack.empty
           ; inner= Stack.map (fun _ -> []) t.boxes }

let rec push k value t =
  let current_length_of_line = current_length_of_line t in

  let append stack len =
    match Stack.pop stack with
    | Some (lenv, stack) -> Stack.push (len :: lenv) stack
    | None -> assert false in

  match value with
  | New_line -> emit_line (merge_indents k) t
  | Open Box ->
    k { t with boxes= Stack.push `Box t.boxes }
  | Open (TBox indent) ->
    k { t with boxes= Stack.push (`Indent indent) t.boxes
             ; inner= Stack.push [] t.inner }
  | Open BBox ->
    let indent = Stack.fold (flip ((+) <.> (List.fold_left (+) 0))) 0 t.inner in
    k { t with boxes= Stack.push (`Indent indent) t.boxes
             ; inner= Stack.push [] t.inner }
  | Close ->
    (* XXX(dinosaure): check [`Root] box. *)
    k { t with boxes= Stack.tail_exn t.boxes
             ; inner= Stack.tail_exn t.inner }
  | Value { breakable; value; } as token ->
    if current_length_of_line + length_of_token (TValue value) > t.margin
    then ( if breakable
           then
             let len = t.margin - current_length_of_line in
             let value0, value1 = split_value len value in
             let token0 = TValue value0 in
             let token1 = Value { breakable; value= value1 } in
             emit_line (merge_indents (push k token1)) { t with queue= Queue.push t.queue token0 }
           else
             ( match Queue.pop t.queue with
               | Some (TBreak _, queue) ->
                 emit_line (merge_indents (push k token)) { t with queue }
               | Some _ | None ->
                 emit_line (merge_indents (push k token)) t ) )
    else k { t with queue= Queue.push t.queue (TValue value)
                  ; inner= append t.inner (length_of_value value) }
  | Break { len; indent; } as break ->
    match let open Option in Queue.tail t.queue >>= merge_breaks break with
    | Some (queue, len) ->
      if current_length_of_line + length_of_token (TBreak len) > t.margin
      then ( emit_line (merge_indents k) { t with queue
                                                ; breaks= Stack.push (`Indent indent) t.breaks } )
      else k { t with queue= Queue.push queue (TBreak len)
                    ; inner= append t.inner len
                    ; breaks= Stack.push (`Indent indent) t.breaks }
    | None ->
      if current_length_of_line + length_of_token (TBreak len) > t.margin
      then ( emit_line (merge_indents k) { t with breaks= Stack.push (`Indent indent) t.breaks } )
      else k { t with queue= Queue.push t.queue (TBreak len)
                    ; inner= append t.inner len
                    ; breaks= Stack.push (`Indent indent) t.breaks }

let create ?(margin= 998) ?(new_line= "\r\n") len =
  let encoder = Enclosure.create len in
  { encoder
  ; queue= Queue.empty
  ; boxes= Stack.push `Root Stack.empty
  ; breaks= Stack.empty
  ; inner= Stack.push [] Stack.empty
  ; indent= 0
  ; margin; new_line; }