Commit bd9892a7 authored by Pietro Abate's avatar Pietro Abate

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

Original author: cvscast
Date: 2002-11-09 18:11:19+00:00
parent 5ed31ef4
......@@ -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
......
......@@ -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
......
......@@ -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 () =
......
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
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
......@@ -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 =
......
......@@ -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))
val set_auth: bool -> unit
val run: string -> Value.t
......@@ -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
;;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment