Restore support for load_xml.

backend/native/cduce_netstring.ml

+open Cduce_types
+open Cduce_core
+open Value
+open Ident
+open Load_xml
+
+let load_html s =
+  let rec val_of_doc q = function
+    | Nethtml.Data data ->
+	if (only_ws (Bytes.unsafe_of_string data) (String.length data)) then q else string data q
+    | Nethtml.Element (tag, att, child) ->
+	let att = List.map (fun (n,v) -> (Label.mk (Ns.empty, U.mk n), U.mk v)) att in
+	pair (elem Ns.empty_table (Atoms.V.mk (Ns.empty,U.mk tag) )
+		att (val_of_docs child)) q
+  and val_of_docs = function
+    | [] -> nil
+    | h::t -> val_of_doc (val_of_docs t) h
+  in
+
+  Cduce_loc.protect_op "load_html";
+  let parse src = Nethtml.parse_document ~dtd:Nethtml.relaxed_html40_dtd src in
+  let doc =
+    if Url.is_url s then
+      parse (Lexing.from_string (Url.load_url s))
+    else
+      let ic = open_in s in
+      let doc =
+	try parse (Lexing.from_channel ic)
+	with exn -> close_in ic; raise exn in
+      close_in ic;
+      doc
+  in
+  let doc = Nethtml.decode ~subst:(fun _ -> "???") doc in
+  let doc = Nethtml.map_list
+	      (Netconversion.convert ~in_enc:`Enc_iso88591
+		 ~out_enc:`Enc_utf8) doc in
+  val_of_docs doc
+
+
+
+
+  let use () =  Load_xml.html_loader := load_html
+
+  let () =
+    Cduce_config.register  ~priority:~-1
+  
+      "netstring"
+      "Load HTML document with netstring"
+      use
+  
\ No newline at end of file

backend/native/cduce_netstring.mli

+val use : unit -> unit

backend/native/dune

@@ -5,7 +5,7 @@
  (modules
   (:standard
    \
-   ("cduce_pxp" cduce_netclient)))
+   ("cduce_pxp" cduce_netclient cduce_netstring)))
  (libraries
   unix
   cduce-types
@@ -30,7 +30,12 @@
    fake_cduce_pxp.ml
    from
    (cduce_pxp -> fake_cduce_pxp.empty.ml)
-   (-> fake_cduce_pxp.empty.ml))))
+   (-> fake_cduce_pxp.empty.ml))
+  (select
+   fake_cduce_netstring.ml
+   from
+   (cduce_netstring -> fake_cduce_netstring.empty.ml)
+   (-> fake_cduce_netstring.empty.ml))))
 
 (library
  (name cduce_pxp)
@@ -47,3 +52,11 @@
  (modules cduce_netclient)
  (library_flags (-linkall))
  (libraries threads.posix netclient cduce-types cduce_core))
+
+(library
+ (name cduce_netstring)
+ (public_name cduce.lib.native_backend.netstring)
+ (optional)
+ (modules cduce_netstring)
+ (library_flags (-linkall))
+ (libraries threads.posix netstring cduce-types cduce_core))

cduce-types.opam

 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.7.0-rc8"
+version: "0.7.0-rc9"
 synopsis: "CDuce type library"
 description: """
 This library implements set-theoretic types with

cduce.opam

 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.7.0-rc8"
+version: "0.7.0-rc9"
 synopsis: "The CDuce compiler"
 description: """
 CDuce is a functional, impure, staticaly typed

dune-project

@@ -2,7 +2,7 @@
 
 (name cduce)
 
-(version 0.7.0-rc8)
+(version 0.7.0-rc9)
 
 (source
  (uri "git+https://gitlab.math.univ-paris-diderot.fr/cduce/cduce/"))

lang/runtime/load_xml.ml

@@ -124,7 +124,8 @@ let load_xml_subst ?(ns=false) s subst =
       | e -> raise e
 
 
-let load_html _ = Cduce_loc.raise_generic "load_html not implemented"
+let html_loader = ref (fun _ -> Cduce_loc.raise_generic "load_html not implemented")
+let load_html s = !html_loader s 
 (*
 let load_html s =
   let rec val_of_doc q = function

lang/runtime/load_xml.mli

-val load_xml: ?ns:bool -> string -> Value.t
-val load_xml_subst: ?ns:bool -> string ->
-  (Ns.Uri.t * Ns.Uri.t) list -> Value.t
-val load_html: string -> Value.t
+val string : string -> Value.t -> Value.t
 
+val attrib :
+  ('a Upool.typed_int * Cduce_types.Ident.U.t) list -> Value.t Imap.t
+
+val elem :
+  Ns.table ->
+  Cduce_types.Atoms.V.t ->
+  ('a Upool.typed_int * Cduce_types.Ident.U.t) list ->
+  Value.t ->
+  Value.t
+
+val only_ws : bytes -> int -> bool
+
+val load_xml : ?ns:bool -> string -> Value.t
+
+val load_xml_subst : ?ns:bool -> string -> (Ns.Uri.t * Ns.Uri.t) list -> Value.t
+
+val html_loader : (string -> Value.t) ref
+
+val load_html : string -> Value.t
 
 (* To define and register a parser *)
 
-val xml_parser: (string -> unit) ref
+val xml_parser : (string -> unit) ref
 
 val start_element_handler : string -> (string * string) list -> unit
+
 val end_element_handler : 'a -> unit
+
 val text_handler : string -> unit