Source file Belt_MutableQueue.ml

module A = Belt_Array

include (
  struct
    type 'a node = { content : 'a; mutable next : 'a cell }
    and 'a cell = 'a node Js.null

    and 'a t = {
      mutable length : int;
      mutable first : 'a cell;
      mutable last : 'a cell;
    }

    let node : content:'a -> next:'a cell -> 'a node =
     fun ~content ~next -> { content; next }

    let content : 'a node -> 'a = fun o -> o.content
    let nextSet : 'a node -> 'a cell -> unit = fun o v -> o.next <- v
    let next : 'a node -> 'a cell = fun o -> o.next

    let t : length:int -> first:'a cell -> last:'a cell -> 'a t =
     fun ~length ~first ~last -> { length; first; last }

    let lengthSet : 'a t -> int -> unit = fun o v -> o.length <- v
    let length : 'a t -> int = fun o -> o.length
    let firstSet : 'a t -> 'a cell -> unit = fun o v -> o.first <- v
    let first : 'a t -> 'a cell = fun o -> o.first
    let lastSet : 'a t -> 'a cell -> unit = fun o v -> o.last <- v
    let last : 'a t -> 'a cell = fun o -> o.last
  end :
    sig
      type 'a node
      and 'a cell = 'a node Js.null
      and 'a t

      val node : content:'a -> next:'a cell -> 'a node
      val content : 'a node -> 'a
      val nextSet : 'a node -> 'a cell -> unit
      val next : 'a node -> 'a cell
      val t : length:int -> first:'a cell -> last:'a cell -> 'a t
      val lengthSet : 'a t -> int -> unit
      val length : 'a t -> int
      val firstSet : 'a t -> 'a cell -> unit
      val first : 'a t -> 'a cell
      val lastSet : 'a t -> 'a cell -> unit
      val last : 'a t -> 'a cell
    end)

let null = Js.null
let return = Js.Null.return
let make () = t ~length:0 ~first:null ~last:null

let clear q =
  lengthSet q 0;
  firstSet q null;
  lastSet q null

let add q x =
  let cell = return @@ node ~content:x ~next:null in
  match Js.nullToOption (last q) with
  | None ->
      lengthSet q 1;
      firstSet q cell;
      lastSet q cell
  | Some last ->
      lengthSet q (length q + 1);
      nextSet last cell;
      lastSet q cell

let peek q =
  match Js.nullToOption (first q) with
  | None -> None
  | Some v -> Some (content v)

let peekUndefined q =
  match Js.nullToOption (first q) with
  | None -> Js.undefined
  | Some v -> Js.Undefined.return (content v)

let peekExn q =
  match Js.nullToOption (first q) with
  | None ->
      let error = Printf.sprintf "File %s, line %d" __FILE__ __LINE__ in
      Js.Exn.raiseError error
  | Some v -> content v

let pop q =
  match Js.nullToOption (first q) with
  | None -> None
  | Some x ->
      let next = next x in
      if next = Js.null then (
        clear q;
        Some (content x))
      else (
        lengthSet q (length q - 1);
        firstSet q next;
        Some (content x))

let popExn q =
  match Js.nullToOption (first q) with
  | None ->
      let error = Printf.sprintf "File %s, line %d" __FILE__ __LINE__ in
      Js.Exn.raiseError error
  | Some x ->
      let next = next x in
      if next = Js.null then (
        clear q;
        content x)
      else (
        lengthSet q (length q - 1);
        firstSet q next;
        content x)

let popUndefined q =
  match Js.nullToOption (first q) with
  | None -> Js.undefined
  | Some x ->
      let next = next x in
      if next = Js.null then (
        clear q;
        Js.Undefined.return (content x))
      else (
        lengthSet q (length q - 1);
        firstSet q next;
        Js.Undefined.return (content x))

let rec copyAux qRes prev cell =
  match Js.nullToOption cell with
  | None ->
      lastSet qRes prev;
      qRes
  | Some x ->
      let content = content x in
      let res = return @@ node ~content ~next:null in
      (match Js.nullToOption prev with
      | None -> firstSet qRes res
      | Some p -> nextSet p res);
      copyAux qRes res (next x)

let copy q =
  copyAux (t ~length:(length q) ~first:null ~last:null) null (first q)

let rec copyMapAux qRes prev cell f =
  match Js.nullToOption cell with
  | None ->
      lastSet qRes prev;
      qRes
  | Some x ->
      let content = f (content x) in
      let res = return @@ node ~content ~next:null in
      (match Js.nullToOption prev with
      | None -> firstSet qRes res
      | Some p -> nextSet p res);
      copyMapAux qRes res (next x) f

let mapU q f =
  copyMapAux (t ~length:(length q) ~first:null ~last:null) null (first q) f

let map q f = mapU q (fun a -> f a)
let isEmpty q = length q = 0
let size q = length q

let rec iterAux cell f =
  match Js.nullToOption cell with
  | None -> ()
  | Some x ->
      f (content x);
      iterAux (next x) f

let forEachU q f = iterAux (first q) f
let forEach q f = forEachU q (fun a -> f a)

let rec foldAux f accu cell =
  match Js.nullToOption cell with
  | None -> accu
  | Some x ->
      let accu = f accu (content x) in
      foldAux f accu (next x)

let reduceU q accu f = foldAux f accu (first q)
let reduce q accu f = reduceU q accu (fun a b -> f a b)

let transfer q1 q2 =
  if length q1 > 0 then
    match Js.nullToOption (last q2) with
    | None ->
        lengthSet q2 (length q1);
        firstSet q2 (first q1);
        lastSet q2 (last q1);
        clear q1
    | Some l ->
        lengthSet q2 (length q2 + length q1);
        nextSet l (first q1);
        lastSet q2 (last q1);
        clear q1

let rec fillAux i arr cell =
  match Js.nullToOption cell with
  | None -> ()
  | Some x ->
      A.setUnsafe arr i (content x);
      fillAux (i + 1) arr (next x)

let toArray x =
  let v =
    match Js.Null.toOption (first x) with
    | None -> [||]
    | Some y -> A.makeUninitializedUnsafe (length x) (content y)
  in
  fillAux 0 v (first x);
  v

let fromArray arr =
  let q = make () in
  for i = 0 to A.length arr - 1 do
    add q (A.getUnsafe arr i)
  done;
  q