[r2002-11-09 18:43:47 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-09 18:43:48+00:00

driver/cduce.ml

 open Location
 
 let print_norm ppf d = 
-  Types.Print.print_descr ppf ((*Types.normalize*) d)
+  Location.protect ppf 
+    (fun ppf -> Types.Print.print_descr ppf ((*Types.normalize*) d))
+
+let print_value ppf v =
+  Location.protect ppf (fun ppf -> Value.print ppf v)
 
 let rec print_exn ppf = function
   | Location (loc, exn) ->
       Format.fprintf ppf "Error %a:@\n" Location.print_loc loc;
-      Format.pp_print_flush ppf ();
-      Format.fprintf (Location.output ()) "%a" Location.html_hilight loc;
+      Format.fprintf ppf "%a" Location.html_hilight loc;
       print_exn ppf exn
   | Value.CDuceExn v ->
       Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
-        Value.print v
+        print_value v
   | Typer.WrongLabel (t,l) ->
       Format.fprintf ppf "Wrong record selection: the label %s@\n" 
         (Types.LabelPool.value l);
@@ -149,7 +152,7 @@ let run ppf input =
     List.iter 
       (fun (x,v) ->
 	 Eval.enter_global x v;
-	 Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
+	 Format.fprintf ppf "=> %s : @[%a@]@\n@." x print_value v
       ) bindings
   in
 
@@ -161,7 +164,7 @@ let run ppf input =
 	  Location.dump_loc (Location.output ()) e.Typed.exp_loc;
 	  Format.fprintf ppf "|- %a@\n@." print_norm t;
 	  let v = Eval.eval !eval_env e in
-	  Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
+	  Format.fprintf ppf "=> @[%a@]@\n@." print_value v
       | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
       | Ast.LetDecl (p,e) ->
 	  let decl = Typer.let_decl p e in

driver/webiface.ml

@@ -13,7 +13,7 @@ let main (cgi : Netcgi.std_activation) =
     Location.set_output ppf;
     Load_xml.set_auth false;
     
-    Cduce.run (Location.protect ppf) input;
+    Cduce.run ppf input;
     let res = Format.flush_str_formatter () in
 
     cgi # output # output_string ("\

parser/location.ml

@@ -67,7 +67,7 @@ let html_hilight ppf (i,j) =
 	let i0 = beg_of_line s i in
 	let j0 = end_of_line s j in
 	Format.fprintf ppf 
-	  "<i>%s<font color=red><b>%s</b></font>%s</div></i>@\n" 
+	  "<i>%s<font color=red><b>%s</b></font>%s</i>@." 
 	    (extr s i0 i)
 	    (extr s i j)
 	    (extr s j j0)
@@ -81,13 +81,17 @@ type expr = A | B of expr located
 let mk loc x = { loc = loc; descr = x }
 
 
-let protect ppf =
+let protect ppf f =
   match !viewport with
     | `Html ->
-	Format.make_formatter
-	(fun s i j -> Format.pp_print_string ppf (extr s i (i+j)))
-	(fun () -> Format.pp_print_flush ppf ())
-    | _ -> ppf
+	let b = Buffer.create 63 in
+	let ppf' = Format.formatter_of_buffer b in
+	f ppf';
+	Format.pp_print_flush ppf' ();
+	let s = Buffer.contents b in
+	let s = Netencoding.Html.encode_from_latin1 s in
+	Format.pp_print_string ppf s
+    | _ -> f ppf
 
 let outputr = ref Format.std_formatter
 let output () = !outputr

parser/location.mli

@@ -15,7 +15,7 @@ val set_viewport: viewport -> unit
 val set_output: Format.formatter -> unit
 val output: unit -> Format.formatter
 
-val protect: Format.formatter -> Format.formatter
+val protect: Format.formatter -> (Format.formatter -> unit) -> unit
 
 val print_loc: Format.formatter -> loc -> unit
 val dump_loc: Format.formatter -> loc -> unit