added tree_with_loc and trees_with_loc

.github/workflows/test.yml

@@ -8,6 +8,8 @@ jobs:
       fail-fast: false
       matrix:
         ocaml:
+        - 5.00.0
+        - 4.14.1
         - 4.13.1
         - 4.12.1
         - 4.11.2
@@ -21,11 +23,12 @@ jobs:
         - 4.03.0
 
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
     - uses: ocaml/setup-ocaml@v2
       with:
         ocaml-compiler: ${{matrix.ocaml}}
-    - run: sudo apt-get install python-bs4
+    - run: sudo apt-get install python3-bs4
+    - run: opam update
     - run: opam install --deps-only --with-test . --yes
     - run: opam install js_of_ocaml --yes
 

src/markup.ml

@@ -39,15 +39,11 @@ 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
 
@@ -73,9 +69,7 @@ type signal = Common.signal
 
 let signal_to_string = Common.signal_to_string
 
-type 's parser =
-  {mutable location : location;
-   mutable signals  : (signal, 's) stream}
+include Utility
 
 let signals parser = parser.signals
 let location parser = parser.location
@@ -159,8 +153,6 @@ let preprocess_input_stream source =
 
 
 
-include Utility
-
 
 
 module Ns =
@@ -244,6 +236,16 @@ sig
     ?xml:(xml_declaration -> 'a) ->
     ?doctype:(doctype -> 'a) ->
     ([< signal ], _) stream -> 'a option io
+
+  val tree_with_loc :
+    ?text:(loc:location -> string list -> 'a) ->
+    ?element:(loc:location -> name -> (name * string) list -> 'a list -> 'a) ->
+    ?comment:(loc:location -> string -> 'a) ->
+    ?pi:(loc:location -> string -> string -> 'a) ->
+    ?xml:(loc:location -> xml_declaration -> 'a) ->
+    ?doctype:(loc:location -> doctype -> 'a) ->
+    's parser -> 'a option io
+
 end
 
 module Asynchronous (IO : IO) =
@@ -332,6 +334,9 @@ struct
 
   let tree ?text ?element ?comment ?pi ?xml ?doctype s =
     Utility.tree ?text ?element ?comment ?pi ?xml ?doctype s |> IO.of_cps
+
+  let tree_with_loc ?text ?element ?comment ?pi ?xml ?doctype s =
+    Utility.tree_with_loc ?text ?element ?comment ?pi ?xml ?doctype s |> IO.of_cps
 end
 
 include Asynchronous (Synchronous)

src/markup.mli

@@ -604,6 +604,18 @@ val trees :
     trees are emitted on the resulting stream, in the sequence that they appear
     in the input. *)
 
+val trees_with_loc :
+  ?text:(loc:location -> string list -> 'a) ->
+  ?element:(loc:location -> name -> (name * string) list -> 'a list -> 'a) ->
+  ?comment:(loc:location -> string -> 'a) ->
+  ?pi:(loc:location -> string -> string -> 'a) ->
+  ?xml:(loc:location -> xml_declaration -> 'a) ->
+  ?doctype:(loc:location -> doctype -> 'a) ->
+  's parser -> ('a, 's) stream
+(** Like {!tree}, but converts all top-level trees, not only the first one. The
+    trees are emitted on the resulting stream, in the sequence that they appear
+    in the input. *)
+
 type 'a node =
   [ `Element of name * (name * string) list * 'a list
   | `Text of string
@@ -890,6 +902,16 @@ sig
     ?xml:(xml_declaration -> 'a) ->
     ?doctype:(doctype -> 'a) ->
     ([< signal ], _) stream -> 'a option io
+
+  val tree_with_loc :
+    ?text:(loc:location -> string list -> 'a) ->
+    ?element:(loc:location -> name -> (name * string) list -> 'a list -> 'a) ->
+    ?comment:(loc:location -> string -> 'a) ->
+    ?pi:(loc:location -> string -> string -> 'a) ->
+    ?xml:(loc:location -> xml_declaration -> 'a) ->
+    ?doctype:(loc:location -> doctype -> 'a) ->
+    's parser -> 'a option io
+
 end
 
 (**/**)

src/utility.ml

@@ -118,6 +118,68 @@ let from_tree f node =
 
   traverse [] node |> List.rev |> of_list
 
+type ('data, 'sync) stream = 'data Kstream.t
+
+type 's parser =
+  {mutable location : location;
+   mutable signals  : (signal, 's) stream}
+
+let trees_with_loc ?text ?element ?comment ?pi ?xml ?doctype s =
+  let rec match_node throw k none =
+    let loc = s.location in
+    next s.signals throw none begin function
+      | `Start_element (name, attributes) ->
+        match_content [] throw (fun children ->
+        match element with
+        | None -> match_node throw k none
+        | Some element -> k (element ~loc name attributes children))
+
+      | `End_element -> none ()
+
+      | `Text ss ->
+        begin match text with
+        | None -> match_node throw k none
+        | Some text -> k (text ~loc ss)
+        end
+
+      | `Doctype d ->
+        begin match doctype with
+        | None -> match_node throw k none
+        | Some doctype -> k (doctype ~loc d)
+        end
+
+      | `Xml x ->
+        begin match xml with
+        | None -> match_node throw k none
+        | Some xml -> k (xml ~loc x)
+        end
+
+      | `PI (t, s) ->
+        begin match pi with
+        | None -> match_node throw k none
+        | Some pi -> k (pi ~loc t s)
+        end
+
+      | `Comment s ->
+        begin match comment with
+        | None -> match_node throw k none
+        | Some comment -> k (comment ~loc s)
+        end
+    end
+
+  and match_content acc throw k =
+    match_node throw
+      (fun n -> match_content (n::acc) throw k)
+      (fun () -> k (List.rev acc))
+
+  in
+
+  (fun throw e k -> match_node throw k e) |> make
+
+let tree_with_loc ?text ?element ?comment ?pi ?xml ?doctype s throw k =
+  let s' = trees_with_loc ?text ?element ?comment ?pi ?xml ?doctype s in
+  next s' throw (fun () -> k None) (fun t -> k (Some t))
+
 let elements select s =
   let depth = ref 0 in
   let started = ref 0 in