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

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

depend

@@ -66,10 +66,10 @@ runtime/eval.cmo: runtime/load_xml.cmi runtime/print_xml.cmo \
 runtime/eval.cmx: runtime/load_xml.cmx runtime/print_xml.cmx \
     runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
     runtime/value.cmx runtime/eval.cmi 
-runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi runtime/value.cmi \
-    runtime/load_xml.cmi 
-runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx runtime/value.cmx \
-    runtime/load_xml.cmi 
+runtime/load_xml.cmo: parser/location.cmi types/sortedMap.cmi types/types.cmi \
+    runtime/value.cmi runtime/load_xml.cmi 
+runtime/load_xml.cmx: parser/location.cmx types/sortedMap.cmx types/types.cmx \
+    runtime/value.cmx runtime/load_xml.cmi 
 runtime/print_xml.cmo: types/chars.cmi types/sequence.cmi types/types.cmi \
     runtime/value.cmi 
 runtime/print_xml.cmx: types/chars.cmx types/sequence.cmx types/types.cmx \
@@ -83,13 +83,19 @@ runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
 runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
     types/types.cmx runtime/value.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
-    parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typer.cmi \
-    types/types.cmi runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi 
+    parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typed.cmo \
+    typing/typer.cmi types/types.cmi runtime/value.cmi parser/wlexer.cmo \
+    driver/cduce.cmi 
 driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
-    parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typer.cmx \
-    types/types.cmx runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi 
+    parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typed.cmx \
+    typing/typer.cmx types/types.cmx runtime/value.cmx parser/wlexer.cmx \
+    driver/cduce.cmi 
 driver/run.cmo: driver/cduce.cmi parser/location.cmi 
 driver/run.cmx: driver/cduce.cmx parser/location.cmx 
+driver/webiface.cmo: driver/cduce.cmi runtime/load_xml.cmi \
+    parser/location.cmi 
+driver/webiface.cmx: driver/cduce.cmx runtime/load_xml.cmx \
+    parser/location.cmx 
 parser/parser.cmi: parser/ast.cmo 
 typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi 
 types/boolean.cmi: types/sortedList.cmi 

driver/cduce.ml

@@ -5,7 +5,10 @@ let print_norm ppf d =
 
 let rec print_exn ppf = function
   | Location (loc, exn) ->
-      Format.fprintf ppf "Error %a:@\n%a" Location.print_loc loc print_exn 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;
+      print_exn ppf exn
   | Value.CDuceExn v ->
       Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@\n"
         Value.print v
@@ -47,6 +50,8 @@ let rec print_exn ppf = function
       Format.fprintf ppf "This comment contains an unterminated string literal@\n"
   | Parser.Error s | Stream.Error s -> 
       Format.fprintf ppf "Parsing error: %s@\n" s
+  | Location.Generic s ->
+      Format.fprintf ppf "%s@\n" s
   | exn ->
       Format.fprintf ppf "%s@\n" (Printexc.to_string exn)
 
@@ -153,6 +158,7 @@ let run ppf input =
       | Ast.EvalStatement e ->
 	  let (fv,e) = Typer.expr e in
 	  let t = Typer.type_check !typing_env e Types.any true in
+	  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

driver/webiface.ml

@@ -4,12 +4,16 @@ open Netcgi
 let main (cgi : Netcgi.std_activation) =
   try
     cgi # set_header ();
-    let cmd = cgi # argument_value "cmd" in
+    let src = cgi # argument_value "prog" in
 
-    Location.set_source (`String cmd);
     let ppf = Format.str_formatter
-    and input = Stream.of_string cmd in
-    Cduce.run ppf input;
+    and input = Stream.of_string src in
+    Location.set_source (`String src);
+    Location.set_viewport `Html;
+    Location.set_output ppf;
+    Load_xml.set_auth false;
+    
+    Cduce.run (Location.protect ppf) input;
     let res = Format.flush_str_formatter () in
 
     cgi # output # output_string ("\
@@ -19,11 +23,11 @@ let main (cgi : Netcgi.std_activation) =
 </head>
 <body>
   <h1>CDuce online prototype</h1>
-  Command == [" ^ cmd ^ "]<br>
-  Result:<pre>" ^ res ^ "</pre>
+<pre>" ^ res ^ "</pre>
 
 <form method=get>
- <input type=text name=cmd length=30>
+ <textarea name=prog cols=80 rows=25></textarea>
+ <input type=submit>
 </form>
 </body>
 </html>
@@ -34,6 +38,7 @@ let main (cgi : Netcgi.std_activation) =
 	cgi # output # rollback_work();
 	cgi # set_header ~status:`Internal_server_error ();
 	cgi # output # output_string "<h1>Internal software error!</h1>";
+	cgi # output # output_string (Printexc.to_string exn);
 	cgi # output # commit_work()
 
 let () =

parser/location.ml

 type loc = int * int
 type source = [ `None | `File of string | `Stream | `String of string ]
+type viewport = [ `Html | `Text ]
 
 exception Location of loc * exn
+exception Generic of string
 
 let noloc = (-1,-1)
 
 let source = ref `None
 let set_source s = source := s
 
+let viewport = ref `Text
+let set_viewport v = viewport := v
+
 let get_line_number src i =
   let ic = open_in_bin src in
   let rec aux pos line start =
@@ -38,10 +43,53 @@ let print_loc ppf (i,j) =
 	  Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
 	    l1 c1 l2 c2
 
+let extr s i j =
+  Netencoding.Html.encode_from_latin1 (String.sub s i (j - i))
+
+let dump_loc ppf (i,j) =
+  match (!source, !viewport) with
+    | (`String s, `Html) ->
+	if (i < 0) then
+	  Format.fprintf ppf "<b>DUMMY</b>@\n"
+	else
+	  Format.fprintf ppf "<i>%s</i>@\n" (extr s i j)
+    | _ -> ()
+
+let rec beg_of_line s i =
+  if (i = 0) || (s.[i-1] = '\n') then i else beg_of_line s (i - 1)
+
+let rec end_of_line s i =
+  if (i = String.length s) || (s.[i] = '\n') then i else end_of_line s (i + 1)
+
+let html_hilight ppf (i,j) =
+  match (!source, !viewport) with
+    | `String s, `Html ->
+	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" 
+	    (extr s i0 i)
+	    (extr s i j)
+	    (extr s j j0)
+    | _ -> ()
+	
+
 type 'a located = { loc : loc; descr : 'a }
 
 type expr = A | B of expr located
 
-let rec recurs f x = f (recurs f) x.loc x.descr
-
 let mk loc x = { loc = loc; descr = x }
+
+
+let protect ppf =
+  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 outputr = ref Format.std_formatter
+let output () = !outputr
+let set_output f = outputr := f
+

parser/location.mli

-type loc = int * int
-type source = [ `None | `File of string | `Stream | `String of string ]
+(* Locations in source file,
+   and presentation of results and errors *)
 
+type loc = int * int
 exception Location of loc * exn
+exception Generic of string
+val noloc:loc
+
+type source = [ `None | `File of string | `Stream | `String of string ]
 val set_source: source -> unit
 
-val noloc:loc
-val get_line_number: string -> int -> int * int
+type viewport = [ `Html | `Text ]
+val set_viewport: viewport -> unit
+
+val set_output: Format.formatter -> unit
+val output: unit -> Format.formatter
+
+val protect: Format.formatter -> Format.formatter
 
 val print_loc: Format.formatter -> loc -> unit
+val dump_loc: Format.formatter -> loc -> unit
+val html_hilight: Format.formatter -> loc -> unit
 
 type 'a located = { loc : loc; descr : 'a }
-val recurs: (('a located -> 'b) -> loc -> 'a -> 'b) -> ('a located -> 'b)
-
 val mk: loc -> 'a -> 'a located

parser/parser.ml

@@ -21,7 +21,7 @@ let rec multi_prod loc = function
       
 let rec tuple loc = function
   | [ x ] -> x
-  | x :: l -> mk (x.loc) (Pair (x, tuple loc l))
+  | x :: l -> mk loc (Pair (x, tuple loc l))
   | [] -> assert false
 
 let tuple_queue = 

runtime/load_xml.ml

@@ -2,6 +2,9 @@
 
 (*TODO: close the file ! *)
 
+let auth = ref true
+let set_auth b = auth := b
+
 open Pxp_yacc
 open Pxp_lexer_types
 open Pxp_types
@@ -70,3 +73,15 @@ let run s =
   get ();
   parse_doc ()
 
+
+let run s =
+  if not !auth then
+    raise 
+      (Location.Generic
+	 "load_xml: operation not authorized in the web prototype"
+      );
+  try run s 
+  with exn ->
+    raise
+      (Location.Generic (Pxp_types.string_of_exn exn))
+      

runtime/load_xml.mli

+val set_auth: bool -> unit
+
 val run: string -> Value.t

tests/biblio.cd

@@ -19,22 +19,22 @@ type Mix   = <h1>[Mix*]
 let fun do_authors ([Author+] -> [Mix*])
  | [ <author>a ] -> a
  | [ <author>a <author>b ] -> a " and, " b
- | [ <author>a; x] -> a ", " (do_authors x)
-in
+ | [ <author>a; x] -> a ", " (do_authors x);;
+
 let fun do_paper (Paper -> <li>[Mix*])
   <paper>[ x::(_* ) <title>t <conference>c <file>f ] ->
 (* Here, type inference says:  x : [Author+] ... *)
     let authors = do_authors x in
-    <li>([ <a href=f>t ] authors "; in " [ <em>c ] "." )
-in
+    <li>([ <a href=f>t ] authors "; in " [ <em>c ] "." );;
+
 let fun do_biblio (Biblio -> Html)
   <bibliography>[ <heading>h; p ] ->
       let body = match p with
       | [] -> "Empty bibliography"
       | l -> [ <h1>h <ul>(map l with x -> do_paper x) ]
       in    
-      <html>[ <head>[ <title>h ] <body>body ]
-in
+      <html>[ <head>[ <title>h ] <body>body ];;
+
 let bib : Biblio = 
   <bibliography>[
     <heading>"Alain Frisch's bibliography"
@@ -63,7 +63,7 @@ let bib : Biblio =
       <conference>"PLANX-02"
       <file>"planx.ps.gz"
     ]
- ]
-in
+ ];;
+
 do_biblio bib
 ;;