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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
(* This file is part of Markup.ml, released under the MIT license. See
   LICENSE.md for details, or visit https://github.com/aantron/markup.ml. *)



module type IO =
sig
  type 'a t

  val return : 'a -> 'a t
  val of_cps : ((exn -> unit) -> ('a -> unit) -> unit) -> 'a t
  val to_cps : (unit -> 'a t) -> ((exn -> unit) -> ('a -> unit) -> unit)
end

module Synchronous : IO with type 'a t = 'a =
struct
  type 'a t = 'a

  exception Not_synchronous

  let return x = x

  let of_cps f =
    let result = ref None in
    f raise (fun v -> result := Some v);
    match !result with
    | None -> raise Not_synchronous
    | Some v -> v

  (* Used in to_cps to avoid the need for a match .. with | exception ..
     expression, which would break compatibility with OCaml < 4.02. Flambda
     seems to optimizes the allocation of these results away completely. There
     is a small performance penalty when not using Flambda. *)
  type 'a result = Value of 'a | Exn of exn

  let to_cps f =
    fun throw k ->
      let result =
        try Value (f ())
        with exn -> Exn exn
      in
      match result with
      | Value v -> k v
      | Exn exn -> throw exn
end



type async = unit
type sync = unit

type ('data, 'sync) stream = 'data Kstream.t

let kstream s = s
let of_kstream s = s

let of_list = Kstream.of_list



type location = Common.location
let compare_locations = Common.compare_locations

module Error = Error



type name = Common.name

type xml_declaration = Common.xml_declaration =
  {version    : string;
   encoding   : string option;
   standalone : bool option}

type doctype = Common.doctype =
  {doctype_name      : string option;
   public_identifier : string option;
   system_identifier : string option;
   raw_text          : string option;
   force_quirks      : bool}

type signal = Common.signal

let signal_to_string = Common.signal_to_string

type 's parser =
  {mutable location : location;
   mutable signals  : (signal, 's) stream}

let signals parser = parser.signals
let location parser = parser.location

let stream_to_parser s =
  let parser = {location = (1, 1); signals = Kstream.empty ()} in
  parser.signals <-
    s |> Kstream.map (fun (l, v) _ k -> parser.location <- l; k v);
  parser

module Cps =
struct
  let parse_xml
      report ?encoding namespace entity context source =
    let with_encoding (encoding : Encoding.t) k =
      source
      |> encoding ~report
      |> Input.preprocess Common.is_valid_xml_char report
      |> Xml_tokenizer.tokenize report entity
      |> Xml_parser.parse context namespace report
      |> k
    in

    let constructor throw k =
      match encoding with
      | Some encoding -> with_encoding encoding k
      | None ->
        Detect.select_xml source throw (fun encoding ->
        with_encoding encoding k)
    in

    Kstream.construct constructor
    |> stream_to_parser

  let write_xml report prefix signals =
    signals
    |> Xml_writer.write report prefix
    |> Utility.strings_to_bytes

  let parse_html report ?encoding context source =
    let with_encoding (encoding : Encoding.t) k =
      source
      |> encoding ~report
      |> Input.preprocess Common.is_valid_html_char report
      |> Html_tokenizer.tokenize report
      |> Html_parser.parse context report
      |> k
    in

    let constructor throw k =
      match encoding with
      | Some encoding -> with_encoding encoding k
      | None ->
        Detect.select_html source throw (fun encoding ->
        with_encoding encoding k)
    in

    Kstream.construct constructor
    |> stream_to_parser

  let write_html ?escape_attribute ?escape_text signals =
    signals
    |> Html_writer.write ?escape_attribute ?escape_text
    |> Utility.strings_to_bytes
end



let string = Stream_io.string
let buffer = Stream_io.buffer
let channel = Stream_io.channel
let file = Stream_io.file

let to_channel c bytes = Stream_io.to_channel c bytes |> Synchronous.of_cps
let to_file f bytes = Stream_io.to_file f bytes |> Synchronous.of_cps



let preprocess_input_stream source =
  Input.preprocess (fun _ -> true) Error.ignore_errors source



include Utility



module Ns =
struct
  let html = Common.html_ns
  let svg = Common.svg_ns
  let mathml = Common.mathml_ns
  let xml = Common.xml_ns
  let xmlns = Common.xmlns_ns
  let xlink = Common.xlink_ns
end



module type ASYNCHRONOUS =
sig
  type 'a io

  module Encoding :
  sig
    type t = Encoding.t

    val decode :
      ?report:(location -> Error.t -> unit io) -> t ->
      (char, _) stream -> (int, async) stream
  end

  val parse_xml :
    ?report:(location -> Error.t -> unit io) ->
    ?encoding:Encoding.t ->
    ?namespace:(string -> string option) ->
    ?entity:(string -> string option) ->
    ?context:[< `Document | `Fragment ] ->
    (char, _) stream -> async parser

  val write_xml :
    ?report:((signal * int) -> Error.t -> unit io) ->
    ?prefix:(string -> string option) ->
    ([< signal ], _) stream -> (char, async) stream

  val parse_html :
    ?report:(location -> Error.t -> unit io) ->
    ?encoding:Encoding.t ->
    ?context:[< `Document | `Fragment of string ] ->
    (char, _) stream -> async parser

  val write_html :
  ?escape_attribute:(string -> string) ->
  ?escape_text:(string -> string) ->
  ([< signal ], _) stream -> (char, async) stream

  val fn : (unit -> char option io) -> (char, async) stream

  val to_string : (char, _) stream -> string io
  val to_buffer : (char, _) stream -> Buffer.t io

  val stream : (unit -> 'a option io) -> ('a, async) stream

  val next : ('a, _) stream -> 'a option io
  val peek : ('a, _) stream -> 'a option io

  val transform :
    ('a -> 'b -> ('c list * 'a option) io) -> 'a -> ('b, _) stream ->
      ('c, async) stream
  val fold : ('a -> 'b -> 'a io) -> 'a -> ('b, _) stream -> 'a io
  val map : ('a -> 'b io) -> ('a, _) stream -> ('b, async) stream
  val filter : ('a -> bool io) -> ('a, _) stream -> ('a, async) stream
  val filter_map : ('a -> 'b option io) -> ('a, _) stream -> ('b, async) stream
  val iter : ('a -> unit io) -> ('a, _) stream -> unit io
  val drain : ('a, _) stream -> unit io

  val to_list : ('a, _) stream -> 'a list io

  val load : ('a, _) stream -> ('a, sync) stream io

  val tree :
    ?text:(string list -> 'a) ->
    ?element:(name -> (name * string) list -> 'a list -> 'a) ->
    ?comment:(string -> 'a) ->
    ?pi:(string -> string -> 'a) ->
    ?xml:(xml_declaration -> 'a) ->
    ?doctype:(doctype -> 'a) ->
    ([< signal ], _) stream -> 'a option io
end

module Asynchronous (IO : IO) =
struct
  let wrap_report report = fun l e -> IO.to_cps (fun () -> report l e)

  module Encoding =
  struct
    include Encoding

    let decode ?(report = fun _ _ -> IO.return ()) (f : Encoding.t) s =
      f ~report:(wrap_report report) s
  end

  let parse_xml
      ?(report = fun _ _ -> IO.return ())
      ?encoding
      ?(namespace = fun _ -> None)
      ?(entity = fun _ -> None)
      ?context
      source =

    Cps.parse_xml
      (wrap_report report) ?encoding namespace entity context source

  let write_xml
      ?(report = fun _ _ -> IO.return ())
      ?(prefix = fun _ -> None)
      signals =

    Cps.write_xml (wrap_report report) prefix signals

  let parse_html
      ?(report = fun _ _ -> IO.return ())
      ?encoding
      ?context
      source =

    Cps.parse_html (wrap_report report) ?encoding context source

  let write_html ?escape_attribute ?escape_text signals =
    Cps.write_html ?escape_attribute ?escape_text signals

  let to_string bytes = Stream_io.to_string bytes |> IO.of_cps
  let to_buffer bytes = Stream_io.to_buffer bytes |> IO.of_cps

  let stream f =
    let f = IO.to_cps f in
    (fun throw e k ->
      f throw (function
        | None -> e ()
        | Some v -> k v))
    |> Kstream.make

  let fn = stream

  let next s = Kstream.next_option s |> IO.of_cps
  let peek s = Kstream.peek_option s |> IO.of_cps

  (* Without Flambda, thunks are repeatedly created and passed on IO.to_cps,
     resulting in a performance penalty. Flambda seems to optimize this away,
     however. *)

  let transform f v s =
    Kstream.transform (fun v s -> IO.to_cps (fun () -> f v s)) v s

  let fold f v s =
    Kstream.fold (fun v v' -> IO.to_cps (fun () -> f v v')) v s |> IO.of_cps

  let map f s = Kstream.map (fun v -> IO.to_cps (fun () -> f v)) s

  let filter f s = Kstream.filter (fun v -> IO.to_cps (fun () -> f v)) s

  let filter_map f s = Kstream.filter_map (fun v -> IO.to_cps (fun () -> f v)) s

  let iter f s =
    Kstream.iter (fun v -> IO.to_cps (fun () -> f v)) s |> IO.of_cps

  let drain s = iter (fun _ -> IO.return ()) s

  let to_list s = Kstream.to_list s |> IO.of_cps

  let load s =
    (fun throw k -> Kstream.to_list s throw (fun l -> k (Kstream.of_list l)))
    |> IO.of_cps

  let tree ?text ?element ?comment ?pi ?xml ?doctype s =
    Utility.tree ?text ?element ?comment ?pi ?xml ?doctype s |> IO.of_cps
end

include Asynchronous (Synchronous)