[r2002-12-20 23:15:22 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-20 23:15:23+00:00

Makefile

@@ -61,6 +61,15 @@ all.cmxa: $(XOBJECTS)
 	$(OCAMLOPT) -a -o $@ $(XOBJECTS)
 
 
+OCAMLDEFUN = /home/frisch/defun/bin/ocamldefun
+DEFUN_FILES = $(OBJECTS:%.cmo=%)
+
+build_defun:
+	for i in $(DEFUN_FILES); do \
+	$(OCAMLDEFUN) $(DIRS:%=-I defun/%) -p -d defun $$i.mli $$i.ml; \
+	$(OCAMLDEFUN) $(DIRS:%=-I defun/%) -p -d defun $$i.ml; \
+	done
+
 memento.html: cduce tests/memento.cd tests/memento.xml
 	./cduce -quiet tests/memento.cd
 

parser/parser.ml

@@ -126,6 +126,7 @@ EXTEND
     |
     [ op = [ LIDENT "flatten"
 	   | LIDENT "load_xml"
+	   | LIDENT "load_html"
 	   | LIDENT "print_xml"
 	   | LIDENT "print"
 	   | LIDENT "raise" 

runtime/eval.ml

@@ -61,6 +61,7 @@ let rec eval env e0 =
     | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
     | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
     | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
+    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
     | Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
     | Typed.Op ("print", [e]) -> eval_print (eval env e)
     | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
@@ -129,7 +130,10 @@ and eval_div x y = match (x,y) with
   | _ -> assert false
 
 and eval_load_xml e =
-  Load_xml.run (get_string e)
+  Load_xml.load_xml (get_string e)
+
+and eval_load_html e =
+  Load_xml.load_html (get_string e)
 
 and eval_int_of e =
   let s = get_string e in

runtime/load_xml.ml

@@ -19,7 +19,14 @@ let is_ws s =
 let string s q =
   String (0,String.length s,s,q)
 
-let run s =
+let attrib att = 
+  let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
+  SortedMap.from_list (fun _ _ -> assert false) att
+
+let elem tag att child =
+  Xml (Atom (Types.AtomPool.mk tag), Pair (Record (attrib att), child))
+
+let load_xml_aux s =
   let config = { default_config with 
 		   store_element_positions = false;
 		   drop_ignorable_whitespace = true
@@ -39,14 +46,7 @@ let run s =
   let txt = Buffer.create 1024 in
 
   let rec parse_elt name att =
-    let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
-    let att = SortedMap.from_list (fun _ _ -> assert false) att in
-    let child = parse_seq () in
-    
-    let elt = Xml 
-		(Atom (Types.AtomPool.mk name),
-		 Pair (Record att, child)
-		) in
+    let elt = elem name att (parse_seq ()) in
     (match !curr with
        | E_end_tag (_,_) -> get ()
        | _ -> failwith "Expect end_tag");
@@ -84,10 +84,30 @@ let run s =
   parse_doc ()
 
 
-let run s =
+let load_xml s =
   Location.protect_op "load_xml";
-  try run s 
+  try load_xml_aux s 
   with exn ->
     raise
       (Location.Generic (Pxp_types.string_of_exn exn))
       
+
+let load_html s =
+  let rec val_of_doc q = function
+    | Nethtml.Data data -> 
+	if (is_ws data) then q else string data q
+    | Nethtml.Element (tag, att, child) -> 
+	Pair (elem tag att (val_of_docs child), q)
+  and val_of_docs = function
+    | [] -> nil
+    | h::t -> val_of_doc (val_of_docs t) h
+  in	
+
+  Location.protect_op "load_xml";
+  let ic = open_in s in
+  let doc = Nethtml.parse_document 
+	      ~dtd:Nethtml.relaxed_html40_dtd 
+	      (Lexing.from_channel ic) in
+  let doc = Nethtml.decode ~subst:(fun _ -> "???") doc in
+  close_in ic;
+  val_of_docs doc

runtime/load_xml.mli

-val run: string -> Value.t
+val load_xml: string -> Value.t
+
+val load_html: string -> Value.t

types/types.ml

@@ -293,8 +293,6 @@ let cache_false = ref Assumptions.empty
 
 exception NotEmpty
 
-let nb_rec = ref 0 and nb_norec = ref 0
-
 let rec empty_rec d =
   if Assumptions.mem d !cache_false then false 
   else if Assumptions.mem d !memo then true
@@ -303,9 +301,7 @@ let rec empty_rec d =
   else if not (Chars.is_empty d.chars) then false
   else (
     let backup = !memo in
-    if is_recurs_descr d then 
-    (incr nb_rec; memo := Assumptions.add d backup)
-    else incr nb_norec;
+    memo := Assumptions.add d backup;
     if 
       (empty_rec_times d.times) &&
       (empty_rec_times d.xml) &&
@@ -1001,7 +997,7 @@ struct
 
   let restrict_label_absent t l =
     Boolean.compute_bool
-      (fun (o,r) as x ->
+      (fun ((o,r) as x) ->
 	 try
 	   let (lo,_) = List.assoc l r in
 	   if lo then atom (o,SortedMap.diff r [l])
@@ -1014,7 +1010,7 @@ struct
     (* Is it correct ?  Do we need to keep track of "first component"
        (value of l) as in label_present, then filter at the end ... ? *)
     Boolean.compute_bool
-      (fun (o,r) as x ->
+      (fun ((o,r) as x) ->
 	 try
 	   let (lo,lt) = List.assoc l r in
 	   if (not lo) && (is_empty (cap d (descr lt))) then Boolean.empty
@@ -1029,7 +1025,7 @@ struct
   let label_present (t:t) l : (descr * t) list =
     let x =
       Boolean.compute_bool
-	(fun (o,r) as x ->
+	(fun ((o,r) as x) ->
 	   try
 	     let (_,lt) = List.assoc l r in
 	     Boolean.atom (descr lt, atom (o, SortedMap.diff r [l]))
@@ -1042,7 +1038,7 @@ struct
 
   let restrict_label_present t l =
     Boolean.compute_bool
-      (fun (o,r) as x ->
+      (fun ((o,r) as x) ->
 	 try
 	   Boolean.atom (o, SortedMap.change_exists l (fun (_,lt) -> (false,lt)) r)
 	 with Not_found -> 
@@ -1440,8 +1436,9 @@ module Char = struct
 end
 
 let print_stat ppf =
-  Format.fprintf ppf "nb_rec = %i@." !nb_rec;
+(*  Format.fprintf ppf "nb_rec = %i@." !nb_rec;
   Format.fprintf ppf "nb_norec = %i@." !nb_norec;
+*)
   ()
 
 (*

typing/typer.ml

@@ -874,6 +874,10 @@ and type_op loc op args =
 	check loc1 t1 Sequence.string
 	  "The argument of load_xml must be a string (filename)";
 	Types.any
+    | "load_html", [loc1,t1] ->
+	check loc1 t1 Sequence.string
+	  "The argument of load_html must be a string (filename)";
+	Types.any
     | "raise", [loc1,t1] ->
 	Types.empty
     | "print_xml", [loc1,t1] ->