Source file io_buffer.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
open Fmlib
open Module_types
open Js_of_ocaml

type position = int

class type dataview =
  object
    method getUint8: position -> char Js.meth
    method setUint8: position -> char -> unit Js.meth
  end

class type buf =
  object
    method length: int Js.readonly_prop
    method copy: buf Js.t -> int -> int -> int -> unit Js.meth
    method rp: int Js.prop
    method wp: int Js.prop
  end



type js_buffer = buf Js.t

type t = {buffer: buf Js.t; view: dataview Js.t}

let js_buffer (b:t): js_buffer =
  b.buffer

let is_empty (b:t): bool =
  b.buffer##.rp = b.buffer##.wp

let is_full (b:t): bool =
  b.buffer##.wp = b.buffer##.length

let read_pointer (b:t): int =
  b.buffer##.rp

let write_pointer (b:t): int =
  b.buffer##.rp

let capacity (b:t): int =
  b.buffer##.length

let length (b:t): int =
  b.buffer##.wp - b.buffer##.rp

let reset (b:t): unit =
  b.buffer##.rp := 0;
  b.buffer##.wp := 0


let set_read_pointer (b:t) (rp:int): unit =
  assert (rp <= b.buffer##.wp);
  b.buffer##.rp := rp

let set_write_pointer (b:t) (wp:int): unit =
  assert (b.buffer##.rp <= wp);
  assert (wp <= b.buffer##.length);
  b.buffer##.wp := wp


let getc (b:t): char option =
  let rp = b.buffer##.rp in
  if rp < b.buffer##.wp then
    (let c = b.view##getUint8 rp in
     b.buffer##.rp := rp + 1;
     Some c)
  else
    None



let putc (b:t) (c:char): unit option =
  let wp = b.buffer##.wp in
  if wp < b.buffer##.length then
    (b.view##setUint8 wp c;
     b.buffer##.wp := wp + 1;
     Some ())
  else
    None


let copy (src:t) (s0:int) (s1:int) (dst:t) (d0:int): unit =
  assert (s0 <= s1);
  assert (d0 + s1 - s0 <= capacity dst);
  src.buffer##copy dst.buffer d0 s0 s1


let alloc (size:int): t =
  let buffer  = (Js.Unsafe.global##.Buffer)##allocUnsafe size in
  buffer##.rp := 0;
  buffer##.wp := 0;
  let view = (* Workaround: I don't know how to call [buffer[i]] from
                ocaml. Therefore I define a view for the buffer and manipulate
                the data in the buffer via the view. *)
    let constr = Js.Unsafe.global##.DataView in
    new%js constr buffer##.buffer
  in
  {buffer; view}



module Read (W:WRITABLE) =
  struct
    let read (b:t) (w:W.t): W.t =
      let rec next w =
        if W.needs_more w then
          match getc b with
          | None ->
             w
          | Some c ->
             next @@ W.putc w c
        else
          w
      in
     next w
  end

module Write (R:READABLE) =
  struct
    let write (b:t) (r:R.t): R.t =
      let r = ref r in
      while R.has_more !r && not (is_full b) do
        let o = putc b (R.peek !r) in
        assert (o <> None);
        r := R.advance !r
      done;
      !r
  end