[r2005-01-06 15:51:35 by afrisch] review html output, prepare demo

Original author: afrisch
Date: 2005-01-06 15:51:38+00:00

Makefile.distrib

@@ -150,6 +150,7 @@ OBJECTS = \
  misc/serialize.cmo misc/custom.cmo \
  misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
  misc/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
+ misc/html.cmo \
  \
  types/sortedList.cmo types/boolean.cmo types/ident.cmo \
  types/intervals.cmo types/chars.cmo types/atoms.cmo \
@@ -215,7 +216,7 @@ VALIDATE_OBJECTS := $(shell for o in $(OBJECTS); do echo $$o; if [ "$$o" = "sche
 
 CDUCE = $(OBJECTS) driver/run.cmo $(CQL_OBJECTS_RUN)
 WEBIFACE  = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
-EVALUATOR = $(OBJECTS) driver/examples.cmo driver/evaluator.cmo
+EVALUATOR = $(OBJECTS) driver/evaluator.cmo
 DTD2CDUCE = tools/dtd2cduce.cmo
 
 ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \

depend

@@ -26,6 +26,8 @@ misc/inttbl.cmo: misc/inttbl.cmi
 misc/inttbl.cmx: misc/inttbl.cmi 
 misc/imap.cmo: misc/imap.cmi 
 misc/imap.cmx: misc/imap.cmi 
+misc/html.cmo: misc/html.cmi 
+misc/html.cmx: misc/html.cmi 
 types/sortedList.cmo: misc/custom.cmo misc/serialize.cmi types/sortedList.cmi 
 types/sortedList.cmx: misc/custom.cmx misc/serialize.cmx types/sortedList.cmi 
 types/boolean.cmo: misc/custom.cmo types/sortedList.cmi types/boolean.cmi 
@@ -175,11 +177,11 @@ runtime/run_dispatch.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
     types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
     runtime/run_dispatch.cmi 
 runtime/explain.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
-    types/ident.cmo types/patterns.cmi types/types.cmi runtime/value.cmi \
-    runtime/explain.cmi 
+    types/ident.cmo types/patterns.cmi runtime/run_dispatch.cmi \
+    types/types.cmi runtime/value.cmi runtime/explain.cmi 
 runtime/explain.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
-    types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
-    runtime/explain.cmi 
+    types/ident.cmx types/patterns.cmx runtime/run_dispatch.cmx \
+    types/types.cmx runtime/value.cmx runtime/explain.cmi 
 runtime/print_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
     types/intervals.cmi parser/location.cmi misc/ns.cmi \
     schema/schema_builtin.cmi types/sequence.cmi runtime/value.cmi \
@@ -244,10 +246,12 @@ driver/cduce.cmx: parser/ast.cmx types/builtin.cmx types/builtin_defs.cmx \
     types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
     misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
     runtime/value.cmx driver/cduce.cmi 
-runtime/system.cmo: types/builtin_defs.cmi parser/location.cmi \
-    compile/operators.cmi runtime/value.cmi 
-runtime/system.cmx: types/builtin_defs.cmx parser/location.cmx \
-    compile/operators.cmx runtime/value.cmx 
+runtime/system.cmo: types/atoms.cmi types/builtin_defs.cmi types/ident.cmo \
+    parser/location.cmi compile/operators.cmi types/types.cmi \
+    runtime/value.cmi 
+runtime/system.cmx: types/atoms.cmx types/builtin_defs.cmx types/ident.cmx \
+    parser/location.cmx compile/operators.cmx types/types.cmx \
+    runtime/value.cmx 
 ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
     types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
     ocamliface/mltypes.cmi 
@@ -302,8 +306,8 @@ driver/webiface.cmo: driver/cduce.cmi driver/examples.cmo parser/location.cmi \
     misc/state.cmi 
 driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \
     misc/state.cmx 
-driver/evaluator.cmo: driver/cduce.cmi parser/location.cmi 
-driver/evaluator.cmx: driver/cduce.cmx parser/location.cmx 
+driver/evaluator.cmo: driver/cduce.cmi driver/config.cmi parser/location.cmi 
+driver/evaluator.cmx: driver/cduce.cmx driver/config.cmx parser/location.cmx 
 tools/validate.cmo: schema/schema_common.cmi schema/schema_parser.cmi \
     schema/schema_types.cmi 
 tools/validate.cmx: schema/schema_common.cmx schema/schema_parser.cmx \
@@ -371,7 +375,7 @@ types/externals.cmi: types/types.cmi
 typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
     parser/location.cmi misc/ns.cmi types/patterns.cmi \
     schema/schema_types.cmi typing/typed.cmo types/types.cmi 
-runtime/load_xml.cmi: runtime/value.cmi 
+runtime/load_xml.cmi: parser/url.cmi runtime/value.cmi 
 runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi 
 runtime/explain.cmi: types/types.cmi runtime/value.cmi 
 runtime/print_xml.cmi: misc/ns.cmi runtime/value.cmi 

driver/cduce.ml

@@ -19,6 +19,7 @@ let prefix filename suff =
 
 let toplevel = ref false
 let verbose = ref false
+let silent = ref false
 
 let typing_env = State.ref "Cduce.typing_env" Builtin.env
 let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
@@ -35,19 +36,16 @@ let rec is_abstraction = function
   | _ -> false
 
 let print_norm ppf d = 
-  Location.protect ppf 
-    (fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
-
+  Types.Print.print ppf ((*Types.normalize*) d)
 
 let print_sample ppf s =
-  Location.protect ppf
-    (fun ppf -> Sample.print ppf s)
+  Sample.print ppf s
 
 let print_protect ppf s =
-  Location.protect ppf (fun ppf -> Format.fprintf ppf "%s" s)
+  Format.fprintf ppf "%s" s
 
 let print_value ppf v =
-  Location.protect ppf (fun ppf -> Value.print ppf v)
+  Value.print ppf v
 
 let dump_value ppf x t v =
   Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
@@ -75,12 +73,14 @@ let directive_help ppf =
                           value of a given expression
   #print_schema <name>;;
   #print_type <name>;;
+  #silent;;               turn off outputs from the toplevel
+  #verbose;;              turn on outputs from the toplevel
 "
 
 let rec print_exn ppf = function
   | Location (loc, w, exn) ->
       Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
-      Format.fprintf ppf "%a" Location.html_hilight (loc,w); 
+      Location.html_hilight (loc,w); 
       print_exn ppf exn
   | Value.CDuceExn v ->
       Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
@@ -123,7 +123,8 @@ let rec print_exn ppf = function
   | Ulexer.Error (i,j,s) ->
       let loc = Location.loc_of_pos (i,j), `Full in
       Format.fprintf ppf "Error %a:@." Location.print_loc loc;
-      Format.fprintf ppf "%a%s" Location.html_hilight loc s
+      Location.html_hilight loc;
+      Format.fprintf ppf "%s" s
   | Parser.Error s | Stream.Error s -> 
       Format.fprintf ppf "Parsing error: %a@." print_protect s
   | Librarian.InconsistentCrc id ->
@@ -196,10 +197,7 @@ let debug ppf tenv cenv = function
       Format.fprintf ppf "[DEBUG:compile]@.";
       let t = Typer.typ tenv t
       and pl = List.map (Typer.pat tenv) pl in  
-      Location.protect ppf 
-	(fun ppf ->
-	   Patterns.Compile.debug_compile ppf t pl
-	)
+      Patterns.Compile.debug_compile ppf t pl
 (*
        Patterns.demo_compile ppf (Types.descr t) (List.map Patterns.descr pl)  
 *)
@@ -265,6 +263,10 @@ let directive ppf tenv cenv = function
   | `Dump pexpr ->
       Value.dump_xml ppf (eval_quiet tenv cenv pexpr);
       flush_ppf ppf
+  | `Silent ->
+      silent := true
+  | `Verbose ->
+      silent := false
 
 let print_id_opt ppf = function
   | None -> Format.fprintf ppf "-"
@@ -275,7 +277,8 @@ let print_value_opt ppf = function
   | Some v -> Format.fprintf ppf " = %a" print_value v
 
 let show ppf id t v =
-  Format.fprintf ppf "@[%a : @[%a%a@]@]@."
+  if !silent then ()
+  else Format.fprintf ppf "@[%a : @[%a%a@]@]@."
     print_id_opt id 
     print_norm t 
     print_value_opt v

driver/evaluator.ml

@@ -36,17 +36,19 @@ let () =
     ignore (Unix.alarm 10);
     Sys.set_signal Sys.sigalrm 
       (Sys.Signal_handle (fun _ -> raise (Cduce.Escape Timeout)));
-    let ppf = Format.str_formatter
+    let v = Location.get_viewport () in
+    let ppf = Html.ppf v 
     and input = Stream.of_string src in
+    Format.pp_set_margin ppf 50;
     Location.push_source (`String src);
     Location.set_protected true;
-    Location.warning_ppf := ppf;
+    Config.init_all ();
     let ok = Cduce.script ppf ppf input in
     if ok then Format.fprintf ppf "@\nOk.@\n";
-    Format.flush_str_formatter ()
+    Html.get v
   in
 
-  Location.set_viewport `Html;
+  Location.set_viewport (Html.create true);
   let prog = Buffer.create 1024 in
   (try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done;
    with End_of_file -> ());

driver/run.ml

@@ -181,6 +181,7 @@ let save () =
     | None -> ()
 
 let main () = 
+  Location.set_viewport (Html.create false);
   match mode () with
     | `Toplevel args ->
 	Config.inhibit "ocaml";

driver/webiface.ml

@@ -253,15 +253,15 @@ let main (cgi : Netcgi.std_activation) =
     in
     
     let exec src =
-      let ppf = Format.str_formatter
+      let v = Location.get_viewport () in
+      let ppf = Html.ppf v
       and input = Stream.of_string src in
       Location.push_source (`String src);
       Location.set_protected true;
       
-      Location.warning_ppf := ppf;
       let ok = Cduce.script ppf ppf input in
       if ok then Format.fprintf ppf "@\nOk.@\n";
-      let res = Format.flush_str_formatter () in
+      let res = Html.get v in
       p "<div class=\"box\"><h2>Results</h2><pre>"; 
       cut (cgi # output # output_char) 80 res;  p "</pre></div>";
       dialog (if !persistant then "" else src);
@@ -279,7 +279,7 @@ let main (cgi : Netcgi.std_activation) =
       dialog src
     in
 
-    Location.set_viewport `Html;
+    Location.set_viewport (Html.create true);
     load_state ();
     store_state ();  (* Just touch the file ... *)
     html_header p;

misc/html.ml

+type t = { 
+  ppf : Format.formatter; buf : Buffer.t; html : bool;
+  mutable marker : int; mutable marks : (int * string) list
+}
+
+let create html = 
+  let buf = Buffer.create 1024 in
+  { ppf = Format.formatter_of_buffer buf;
+    buf = buf;
+    html = html;
+    marker = 0; marks = [] }
+
+let ppf x = x.ppf
+
+let mark x s =
+  if x.html then (
+    let m  = x.marker in
+    x.marker <- m + 1;
+    x.marks <- (m, s) :: x.marks;
+    Format.pp_print_as x.ppf 0 ("\000" ^ (string_of_int m) ^ "\000")
+  )
+
+let markup x s p =
+  if x.html then (
+    mark x ("<"^s^">");
+    p x.ppf;
+    mark x ("</"^s^">");
+  ) else
+    p x.ppf
+
+let get x =
+  Format.pp_print_flush x.ppf ();
+  let s = Buffer.contents x.buf in
+  Buffer.clear x.buf;
+  let rec aux i =
+    if i = String.length s then ()
+    else match s.[i] with
+      | '\000' ->
+	  let j = 
+	    try String.index_from s (i+1) '\000' 
+	    with Not_found -> assert false in
+	  let m = int_of_string (String.sub s (i+1) (j-i-1)) in
+	  let m = List.assq m x.marks in
+	  Buffer.add_string x.buf m;
+	  aux (j+1)
+      | '<' ->
+	  Buffer.add_string x.buf "&lt;";
+	  aux (i+1)
+      | '&' ->
+	  Buffer.add_string x.buf "&amp;";
+	  aux (i+1)
+      | ('\000'..'\008' | '\011' | '\012' | '\013'..'\031' | '\127') as c ->
+	  Buffer.add_string x.buf (Printf.sprintf "&#%i;" (Char.code c));
+	  aux (i+1)
+      | c ->
+	  Buffer.add_char x.buf c;
+	  aux (i+1)
+  in
+  aux 0;
+  let s = Buffer.contents x.buf in
+  Buffer.clear x.buf;
+  x.marker <- 0;
+  x.marks <- [];
+  s
+
+let is_html x = x.html

misc/html.mli

+type t
+
+val create: bool -> t
+val ppf: t -> Format.formatter
+val get: t -> string
+val mark: t -> string -> unit
+val markup: t -> string -> (Format.formatter -> unit) -> unit
+val is_html: t -> bool
+

parser/ast.ml

@@ -35,6 +35,8 @@ and toplevel_directive =
   | `Print_schema_type of Schema_types.component_kind * U.t * U.t
   | `Print_type of U.t
   | `Debug of debug_directive
+  | `Verbose
+  | `Silent
   ]
 
 

parser/location.ml

@@ -5,8 +5,6 @@ type source = [ `None | `File of string | `Stream | `String of string ]
 type loc = source * int * int
 type precise = [ `Full | `Char of int ]
 
-type viewport = [ `Html | `Text ]
-
 let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
   if s1 = s2 then 
     if i1 = -1 then loc2 else if i2 = -1 then loc1 else 
@@ -26,8 +24,6 @@ let current_dir () =
     | `File s -> Filename.dirname s
     | _ -> ""
 
-let warning_ppf = ref Format.std_formatter
-
 exception Location of loc * precise * exn
 exception Generic of string
 
@@ -38,8 +34,11 @@ let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s))
 let noloc = (`None,-1,-1)
 let nopos = (-1,-1)
 
-let viewport = ref `Text
-let set_viewport v = viewport := v
+let viewport = ref None
+let set_viewport v = viewport := Some v
+let get_viewport () = match !viewport with
+  | None -> assert false
+  | Some x -> x
 
 (* Note: this is incorrect. Directives #utf8,... should
    not be recognized inside comments and strings !
@@ -102,13 +101,14 @@ let extr s i j =
   with e -> failwith (Printf.sprintf "Location.extr len=%i i=%i j=%i"
 			(String.length s) i j )
 
-let dump_loc ppf ((src,i,j),w) =
-  match (src, !viewport) with
-    | (`String s, `Html) ->
+let dump_loc ((src,i,j),w) =
+  let v = get_viewport () in
+  match (src, Html.is_html v) with
+    | (`String s, true) ->
 	if (i < 0) then
-	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
+	  Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
 	else
-	  Format.fprintf ppf "<i>%s</i>@." (extr s i j)
+	  Html.markup v "i" (fun ppf -> Format.fprintf ppf "%s" (extr s i j))
     | _ -> ()
 
 let rec beg_of_line s i =
@@ -119,19 +119,24 @@ let rec end_of_line s i =
   if (i >= String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
   then i else end_of_line s (i + 1)
 
-let html_hilight ppf ((src,i,j),w) =
-  match (src, !viewport) with
-    | `String s, `Html ->
+let html_hilight ((src,i,j),w) =
+  let v = get_viewport () in
+  match (src, Html.is_html v) with
+    | `String s, true ->
 	if (i < 0) then
-	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
+	  Html.markup v "b" 
+	    (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
 	else
-	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</i>@." 
-	    (extr s i0 i)
-	    (extr s i j)
-	    (extr s j j0)
+	  let i0 = beg_of_line s i in
+	  let j0 = end_of_line s j in
+	  Html.markup v "i"
+	    (fun ppf ->
+	       Format.fprintf ppf "%s" (extr s i0 i);
+	       Html.mark v "<font color=\"red\"><b>";
+	       Format.fprintf ppf "%s" (extr s i j);
+	       Html.mark v "</b></font>";
+	       Format.fprintf ppf "%s@." (extr s j j0);
+	    )
     | _ -> ()
 	
 
@@ -142,18 +147,20 @@ let mk_loc loc x = { loc = loc; descr = x }
 let mknoloc x = { loc = noloc; descr = x }
 let loc_of_pos (i,j) = (!source,i,j)
 
+(*
 let protect ppf f =
   match !viewport with
     | `Html ->
 	let b = Buffer.create 63 in
 	let ppf' = Format.formatter_of_buffer b in
+	Format.pp_set_margin ppf' (Format.pp_get_margin ppf ());
 	f ppf';
 	Format.pp_print_flush ppf' ();
 	let s = Buffer.contents b in
 	let s = Netencoding.Html.encode_from_latin1 s in
 	Format.fprintf ppf "@[%s@]" s
     | _ -> f ppf
-
+*)
 
 
 let protected = ref false

parser/location.mli

@@ -21,16 +21,16 @@ val pop_source: unit -> unit
 
 val current_dir : unit -> string
 
-val warning_ppf : Format.formatter ref
-
-type viewport = [ `Html | `Text ]
-val set_viewport: viewport -> unit
+val set_viewport: Html.t -> unit
+val get_viewport: unit -> Html.t
 
+(*
 val protect: Format.formatter -> (Format.formatter -> unit) -> unit
+*)
 
 val print_loc: Format.formatter -> loc * precise -> unit
-val dump_loc: Format.formatter -> loc * precise -> unit
-val html_hilight: Format.formatter -> loc * precise -> unit
+val dump_loc: loc * precise -> unit
+val html_hilight: loc * precise -> unit
 
 type 'a located = { loc : loc; descr : 'a }
 val mk: int * int -> 'a -> 'a located

parser/parser.ml

@@ -129,6 +129,8 @@ EXTEND
 	let e = exp loc (NamespaceIn (name, ns, e2)) in
         [ mk loc (EvalStatement (exp loc e)) ]
     | "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
+    | DIRECTIVE "#verbose" -> [ mk loc (Directive `Verbose) ]
+    | DIRECTIVE "#silent" -> [ mk loc (Directive `Silent) ]
     | DIRECTIVE "#utf8" -> Ulexer.enc := Ulexing.Utf8; [ ]
     | DIRECTIVE "#latin1" -> Ulexer.enc := Ulexing.Latin1; [ ]
     | DIRECTIVE "#ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]

parser/url.ml

@@ -23,6 +23,7 @@ let load_url = ref no_load_url
 let process s =
   match start_with s "string://" with
     | None -> 
+	Location.protect_op "load_xml";
 	if is_url s then Url (!load_url s)
 	else Filename s
     | Some s ->

runtime/cduce_expat.ml

@@ -26,7 +26,7 @@ let load_expat s =
   Expat.set_end_element_handler p Load_xml.end_element_handler;
   Expat.set_character_data_handler p Load_xml.text_handler;
   try
-    match Url.process s with 
+    match s with 
       | Url.Url s -> Expat.parse p s
       | Url.Filename s -> load_from_file p s
   with Expat.Expat_error e -> 

runtime/cduce_pxp.ml

@@ -21,7 +21,7 @@ let pxp_config =
 let load_pxp s =
   try
     let src = 
-      match Url.process s with 
+      match s with 
         | Url.Url s -> from_string s
         | Url.Filename s -> from_file s in
     let mgr = create_entity_manager pxp_config src in

runtime/load_xml.ml

@@ -91,7 +91,7 @@ let xml_parser = ref (fun s -> failwith "No XML parser available")
 
 
 let load_xml s =
-  Location.protect_op "load_xml";
+  let s = Url.process s in
   try
     !xml_parser s;
     match !stack with

runtime/load_xml.mli

@@ -4,7 +4,7 @@ val load_html: string -> Value.t
 
 (* To define and register a parser *)
 
-val xml_parser: (string -> unit) ref
+val xml_parser: (Url.url -> unit) ref
 
 val start_element_handler : string -> (string * string) list -> unit
 val end_element_handler : 'a -> unit

types/patterns.ml

@@ -1476,6 +1476,7 @@ struct
     | AIgnore r -> Format.fprintf ppf "v -> %a@\n" print_ret r
 
   let print_dispatcher ppf d =
+(*
     Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
       d.id Types.Print.print (Types.normalize d.t); 
     let print_code code (t, arity, m) =
@@ -1495,6 +1496,7 @@ struct
       Format.fprintf ppf "@\n";
     in
     Array.iteri print_code d.codes;   
+*)
     Format.fprintf ppf "let disp_%i = function@\n" d.id;
     print_actions ppf (actions d);
     Format.fprintf ppf "====================================@\n"

typing/typer.ml

@@ -11,10 +11,11 @@ open Ident
 let debug_schema = false
 
 let warning loc msg =
-  Format.fprintf !Location.warning_ppf "Warning %a:@\n%a%s@." 
-    Location.print_loc (loc,`Full)
-    Location.html_hilight (loc,`Full)
-    msg
+  let v = Location.get_viewport () in
+  let ppf = Html.ppf v in
+  Format.fprintf ppf "Warning %a:@\n" Location.print_loc (loc,`Full);
+  Location.html_hilight (loc,`Full);
+  Format.fprintf ppf "%s@." msg
 
 exception NonExhaustive of Types.descr
 exception Constraint of Types.descr * Types.descr

web/demo.js

@@ -33,7 +33,15 @@ function submit(pr) {
   if (xmlhttp.readyState==4) { show_result(pr,xmlhttp.responseText); }
  }
  show_result(pr,"Computing...");
- xmlhttp.send(document.getElementById(pr+"edit").value);
+ xmlhttp.send("#silent\n"+compute_prefix(pr) + "#verbose\n"+document.getElementById(pr+"edit").value);
+}
+
+function compute_prefix(pr) {
+ var prefix = document.getElementById(pr+"prefix").value;
+ if (prefix == "") return "";
+ var r = compute_prefix(prefix) + document.getElementById(prefix+"def").value;
+// alert("pr="+pr+" prefix="+prefix+" r="+r);
+ return(r + "\n");
 }
 
 function editable(pr,b) {