Commit a4c73a11 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent 7b104e89
...@@ -150,6 +150,7 @@ OBJECTS = \ ...@@ -150,6 +150,7 @@ OBJECTS = \
misc/serialize.cmo misc/custom.cmo \ misc/serialize.cmo misc/custom.cmo \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.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/pretty.cmo misc/ns.cmo misc/inttbl.cmo misc/imap.cmo \
misc/html.cmo \
\ \
types/sortedList.cmo types/boolean.cmo types/ident.cmo \ types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.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 ...@@ -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) CDUCE = $(OBJECTS) driver/run.cmo $(CQL_OBJECTS_RUN)
WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo 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 DTD2CDUCE = tools/dtd2cduce.cmo
ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \ ALL_OBJECTS = $(OBJECTS) $(NEW_SCHEMA_OBJS) \
......
...@@ -26,6 +26,8 @@ misc/inttbl.cmo: misc/inttbl.cmi ...@@ -26,6 +26,8 @@ misc/inttbl.cmo: misc/inttbl.cmi
misc/inttbl.cmx: misc/inttbl.cmi misc/inttbl.cmx: misc/inttbl.cmi
misc/imap.cmo: misc/imap.cmi misc/imap.cmo: misc/imap.cmi
misc/imap.cmx: 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.cmo: misc/custom.cmo misc/serialize.cmi types/sortedList.cmi
types/sortedList.cmx: misc/custom.cmx misc/serialize.cmx 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 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 \ ...@@ -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 \ types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi runtime/run_dispatch.cmi
runtime/explain.cmo: types/atoms.cmi types/chars.cmi misc/encodings.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 \ types/ident.cmo types/patterns.cmi runtime/run_dispatch.cmi \
runtime/explain.cmi types/types.cmi runtime/value.cmi runtime/explain.cmi
runtime/explain.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \ runtime/explain.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \ types/ident.cmx types/patterns.cmx runtime/run_dispatch.cmx \
runtime/explain.cmi types/types.cmx runtime/value.cmx runtime/explain.cmi
runtime/print_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \ runtime/print_xml.cmo: types/atoms.cmi misc/encodings.cmi types/ident.cmo \
types/intervals.cmi parser/location.cmi misc/ns.cmi \ types/intervals.cmi parser/location.cmi misc/ns.cmi \
schema/schema_builtin.cmi types/sequence.cmi runtime/value.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 \ ...@@ -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 \ types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \ misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi runtime/value.cmx driver/cduce.cmi
runtime/system.cmo: types/builtin_defs.cmi parser/location.cmi \ runtime/system.cmo: types/atoms.cmi types/builtin_defs.cmi types/ident.cmo \
compile/operators.cmi runtime/value.cmi parser/location.cmi compile/operators.cmi types/types.cmi \
runtime/system.cmx: types/builtin_defs.cmx parser/location.cmx \ runtime/value.cmi
compile/operators.cmx runtime/value.cmx 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 \ ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \ types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
ocamliface/mltypes.cmi ocamliface/mltypes.cmi
...@@ -302,8 +306,8 @@ driver/webiface.cmo: driver/cduce.cmi driver/examples.cmo parser/location.cmi \ ...@@ -302,8 +306,8 @@ driver/webiface.cmo: driver/cduce.cmi driver/examples.cmo parser/location.cmi \
misc/state.cmi misc/state.cmi
driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \ driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx misc/state.cmx
driver/evaluator.cmo: driver/cduce.cmi parser/location.cmi driver/evaluator.cmo: driver/cduce.cmi driver/config.cmi parser/location.cmi
driver/evaluator.cmx: driver/cduce.cmx parser/location.cmx driver/evaluator.cmx: driver/cduce.cmx driver/config.cmx parser/location.cmx
tools/validate.cmo: schema/schema_common.cmi schema/schema_parser.cmi \ tools/validate.cmo: schema/schema_common.cmi schema/schema_parser.cmi \
schema/schema_types.cmi schema/schema_types.cmi
tools/validate.cmx: schema/schema_common.cmx schema/schema_parser.cmx \ tools/validate.cmx: schema/schema_common.cmx schema/schema_parser.cmx \
...@@ -371,7 +375,7 @@ types/externals.cmi: types/types.cmi ...@@ -371,7 +375,7 @@ types/externals.cmi: types/types.cmi
typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \ typing/typer.cmi: parser/ast.cmo misc/custom.cmo types/ident.cmo \
parser/location.cmi misc/ns.cmi types/patterns.cmi \ parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_types.cmi typing/typed.cmo types/types.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/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/explain.cmi: types/types.cmi runtime/value.cmi runtime/explain.cmi: types/types.cmi runtime/value.cmi
runtime/print_xml.cmi: misc/ns.cmi runtime/value.cmi runtime/print_xml.cmi: misc/ns.cmi runtime/value.cmi
......
...@@ -19,6 +19,7 @@ let prefix filename suff = ...@@ -19,6 +19,7 @@ let prefix filename suff =
let toplevel = ref false let toplevel = ref false
let verbose = ref false let verbose = ref false
let silent = ref false
let typing_env = State.ref "Cduce.typing_env" Builtin.env let typing_env = State.ref "Cduce.typing_env" Builtin.env
let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel let compile_env = State.ref "Cduce.compile_env" Compile.empty_toplevel
...@@ -35,19 +36,16 @@ let rec is_abstraction = function ...@@ -35,19 +36,16 @@ let rec is_abstraction = function
| _ -> false | _ -> false
let print_norm ppf d = let print_norm ppf d =
Location.protect ppf Types.Print.print ppf ((*Types.normalize*) d)
(fun ppf -> Types.Print.print ppf ((*Types.normalize*) d))
let print_sample ppf s = let print_sample ppf s =
Location.protect ppf Sample.print ppf s
(fun ppf -> Sample.print ppf s)
let print_protect 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 = 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 = let dump_value ppf x t v =
Format.fprintf ppf "@[val %a : @[%a = %a@]@]@." Format.fprintf ppf "@[val %a : @[%a = %a@]@]@."
...@@ -75,12 +73,14 @@ let directive_help ppf = ...@@ -75,12 +73,14 @@ let directive_help ppf =
value of a given expression value of a given expression
#print_schema <name>;; #print_schema <name>;;
#print_type <name>;; #print_type <name>;;
#silent;; turn off outputs from the toplevel
#verbose;; turn on outputs from the toplevel
" "
let rec print_exn ppf = function let rec print_exn ppf = function
| Location (loc, w, exn) -> | Location (loc, w, exn) ->
Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w); 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 print_exn ppf exn
| Value.CDuceExn v -> | Value.CDuceExn v ->
Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@." Format.fprintf ppf "Uncaught CDuce exception: @[%a@]@."
...@@ -123,7 +123,8 @@ let rec print_exn ppf = function ...@@ -123,7 +123,8 @@ let rec print_exn ppf = function
| Ulexer.Error (i,j,s) -> | Ulexer.Error (i,j,s) ->
let loc = Location.loc_of_pos (i,j), `Full in let loc = Location.loc_of_pos (i,j), `Full in
Format.fprintf ppf "Error %a:@." Location.print_loc loc; 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 -> | Parser.Error s | Stream.Error s ->
Format.fprintf ppf "Parsing error: %a@." print_protect s Format.fprintf ppf "Parsing error: %a@." print_protect s
| Librarian.InconsistentCrc id -> | Librarian.InconsistentCrc id ->
...@@ -196,10 +197,7 @@ let debug ppf tenv cenv = function ...@@ -196,10 +197,7 @@ let debug ppf tenv cenv = function
Format.fprintf ppf "[DEBUG:compile]@."; Format.fprintf ppf "[DEBUG:compile]@.";
let t = Typer.typ tenv t let t = Typer.typ tenv t
and pl = List.map (Typer.pat tenv) pl in 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) Patterns.demo_compile ppf (Types.descr t) (List.map Patterns.descr pl)
*) *)
...@@ -265,6 +263,10 @@ let directive ppf tenv cenv = function ...@@ -265,6 +263,10 @@ let directive ppf tenv cenv = function
| `Dump pexpr -> | `Dump pexpr ->
Value.dump_xml ppf (eval_quiet tenv cenv pexpr); Value.dump_xml ppf (eval_quiet tenv cenv pexpr);
flush_ppf ppf flush_ppf ppf
| `Silent ->
silent := true
| `Verbose ->
silent := false
let print_id_opt ppf = function let print_id_opt ppf = function
| None -> Format.fprintf ppf "-" | None -> Format.fprintf ppf "-"
...@@ -275,7 +277,8 @@ let print_value_opt ppf = function ...@@ -275,7 +277,8 @@ let print_value_opt ppf = function
| Some v -> Format.fprintf ppf " = %a" print_value v | Some v -> Format.fprintf ppf " = %a" print_value v
let show ppf id t 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_id_opt id
print_norm t print_norm t
print_value_opt v print_value_opt v
......
...@@ -36,17 +36,19 @@ let () = ...@@ -36,17 +36,19 @@ let () =
ignore (Unix.alarm 10); ignore (Unix.alarm 10);
Sys.set_signal Sys.sigalrm Sys.set_signal Sys.sigalrm
(Sys.Signal_handle (fun _ -> raise (Cduce.Escape Timeout))); (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 and input = Stream.of_string src in
Format.pp_set_margin ppf 50;
Location.push_source (`String src); Location.push_source (`String src);
Location.set_protected true; Location.set_protected true;
Location.warning_ppf := ppf; Config.init_all ();
let ok = Cduce.script ppf ppf input in let ok = Cduce.script ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n"; if ok then Format.fprintf ppf "@\nOk.@\n";
Format.flush_str_formatter () Html.get v
in in
Location.set_viewport `Html; Location.set_viewport (Html.create true);
let prog = Buffer.create 1024 in let prog = Buffer.create 1024 in
(try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done; (try while true do Buffer.add_string prog (read_line ()); Buffer.add_string prog "\n" done;
with End_of_file -> ()); with End_of_file -> ());
......
...@@ -181,6 +181,7 @@ let save () = ...@@ -181,6 +181,7 @@ let save () =
| None -> () | None -> ()
let main () = let main () =
Location.set_viewport (Html.create false);
match mode () with match mode () with
| `Toplevel args -> | `Toplevel args ->
Config.inhibit "ocaml"; Config.inhibit "ocaml";
......
...@@ -253,15 +253,15 @@ let main (cgi : Netcgi.std_activation) = ...@@ -253,15 +253,15 @@ let main (cgi : Netcgi.std_activation) =
in in
let exec src = 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 and input = Stream.of_string src in
Location.push_source (`String src); Location.push_source (`String src);
Location.set_protected true; Location.set_protected true;
Location.warning_ppf := ppf;
let ok = Cduce.script ppf ppf input in let ok = Cduce.script ppf ppf input in
if ok then Format.fprintf ppf "@\nOk.@\n"; 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>"; p "<div class=\"box\"><h2>Results</h2><pre>";
cut (cgi # output # output_char) 80 res; p "</pre></div>"; cut (cgi # output # output_char) 80 res; p "</pre></div>";
dialog (if !persistant then "" else src); dialog (if !persistant then "" else src);
...@@ -279,7 +279,7 @@ let main (cgi : Netcgi.std_activation) = ...@@ -279,7 +279,7 @@ let main (cgi : Netcgi.std_activation) =
dialog src dialog src
in in
Location.set_viewport `Html; Location.set_viewport (Html.create true);
load_state (); load_state ();
store_state (); (* Just touch the file ... *) store_state (); (* Just touch the file ... *)
html_header p; html_header p;
......
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
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
...@@ -35,6 +35,8 @@ and toplevel_directive = ...@@ -35,6 +35,8 @@ and toplevel_directive =
| `Print_schema_type of Schema_types.component_kind * U.t * U.t | `Print_schema_type of Schema_types.component_kind * U.t * U.t
| `Print_type of U.t | `Print_type of U.t
| `Debug of debug_directive | `Debug of debug_directive
| `Verbose
| `Silent
] ]
......
...@@ -5,8 +5,6 @@ type source = [ `None | `File of string | `Stream | `String of string ] ...@@ -5,8 +5,6 @@ type source = [ `None | `File of string | `Stream | `String of string ]
type loc = source * int * int type loc = source * int * int
type precise = [ `Full | `Char of int ] type precise = [ `Full | `Char of int ]
type viewport = [ `Html | `Text ]
let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) = let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
if s1 = s2 then if s1 = s2 then
if i1 = -1 then loc2 else if i2 = -1 then loc1 else if i1 = -1 then loc2 else if i2 = -1 then loc1 else
...@@ -26,8 +24,6 @@ let current_dir () = ...@@ -26,8 +24,6 @@ let current_dir () =
| `File s -> Filename.dirname s | `File s -> Filename.dirname s
| _ -> "" | _ -> ""
let warning_ppf = ref Format.std_formatter
exception Location of loc * precise * exn exception Location of loc * precise * exn
exception Generic of string exception Generic of string
...@@ -38,8 +34,11 @@ let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s)) ...@@ -38,8 +34,11 @@ let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s))
let noloc = (`None,-1,-1) let noloc = (`None,-1,-1)
let nopos = (-1,-1) let nopos = (-1,-1)
let viewport = ref `Text let viewport = ref None
let set_viewport v = viewport := v 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 (* Note: this is incorrect. Directives #utf8,... should
not be recognized inside comments and strings ! not be recognized inside comments and strings !
...@@ -102,13 +101,14 @@ let extr s i j = ...@@ -102,13 +101,14 @@ let extr s i j =
with e -> failwith (Printf.sprintf "Location.extr len=%i i=%i j=%i" with e -> failwith (Printf.sprintf "Location.extr len=%i i=%i j=%i"
(String.length s) i j ) (String.length s) i j )
let dump_loc ppf ((src,i,j),w) = let dump_loc ((src,i,j),w) =
match (src, !viewport) with let v = get_viewport () in
| (`String s, `Html) -> match (src, Html.is_html v) with
| (`String s, true) ->
if (i < 0) then if (i < 0) then
Format.fprintf ppf "<b>GHOST LOCATION</b>@\n" Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else 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 = let rec beg_of_line s i =
...@@ -119,19 +119,24 @@ let rec end_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') if (i >= String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
then i else end_of_line s (i + 1) then i else end_of_line s (i + 1)
let html_hilight ppf ((src,i,j),w) = let html_hilight ((src,i,j),w) =
match (src, !viewport) with let v = get_viewport () in
| `String s, `Html -> match (src, Html.is_html v) with
| `String s, true ->
if (i < 0) then if (i < 0) then
Format.fprintf ppf "<b>GHOST LOCATION</b>@\n" Html.markup v "b"
(fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
else else
let i0 = beg_of_line s i in let i0 = beg_of_line s i in
let j0 = end_of_line s j in let j0 = end_of_line s j in
Format.fprintf ppf Html.markup v "i"
"<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@." (fun ppf ->
(extr s i0 i) Format.fprintf ppf "%s" (extr s i0 i);
(extr s i j) Html.mark v "<font color=\"red\"><b>";
(extr s j j0) 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 } ...@@ -142,18 +147,20 @@ let mk_loc loc x = { loc = loc; descr = x }
let mknoloc x = { loc = noloc; descr = x } let mknoloc x = { loc = noloc; descr = x }
let loc_of_pos (i,j) = (!source,i,j) let loc_of_pos (i,j) = (!source,i,j)
(*
let protect ppf f = let protect ppf f =
match !viewport with match !viewport with
| `Html -> | `Html ->
let b = Buffer.create 63 in let b = Buffer.create 63 in
let ppf' = Format.formatter_of_buffer b in let ppf' = Format.formatter_of_buffer b in
Format.pp_set_margin ppf' (Format.pp_get_margin ppf ());
f ppf'; f ppf';
Format.pp_print_flush ppf' (); Format.pp_print_flush ppf' ();
let s = Buffer.contents b in let s = Buffer.contents b in
let s = Netencoding.Html.encode_from_latin1 s in let s = Netencoding.Html.encode_from_latin1 s in
Format.fprintf ppf "@[%s@]" s Format.fprintf ppf "@[%s@]" s
| _ -> f ppf | _ -> f ppf
*)
let protected = ref false let protected = ref false
......
...@@ -21,16 +21,16 @@ val pop_source: unit -> unit ...@@ -21,16 +21,16 @@ val pop_source: unit -> unit
val current_dir : unit -> string val current_dir : unit -> string
val warning_ppf : Format.formatter ref val set_viewport: Html.t -> unit
val get_viewport: unit -> Html.t
type viewport = [ `Html | `Text ]
val set_viewport: viewport -> unit
(*
val protect: Format.formatter -> (Format.formatter -> unit) -> unit val protect: Format.formatter -> (Format.formatter -> unit) -> unit
*)
val print_loc: Format.formatter -> loc * precise -> unit val print_loc: Format.formatter -> loc * precise -> unit
val dump_loc: Format.formatter -> loc * precise -> unit val dump_loc: loc * precise -> unit
val html_hilight: Format.formatter -> loc * precise -> unit val html_hilight: loc * precise -> unit
type 'a located = { loc : loc; descr : 'a } type 'a located = { loc : loc; descr : 'a }
val mk: int * int -> 'a -> 'a located val mk: int * int -> 'a -> 'a located
......
...@@ -129,6 +129,8 @@ EXTEND ...@@ -129,6 +129,8 @@ EXTEND
let e = exp loc (NamespaceIn (name, ns, e2)) in let e = exp loc (NamespaceIn (name, ns, e2)) in