[r2005-07-30 09:27:30 by afrisch] New printer for locations

Original author: afrisch
Date: 2005-07-30 09:27:30+00:00

driver/cduce.ml

@@ -79,7 +79,7 @@ let directive_help ppf =
 
 let rec print_exn ppf = function
   | Location (loc, w, exn) ->
-      Format.fprintf ppf "Error %a:@." Location.print_loc (loc,w);
+      Location.print_loc ppf (loc,w);
       Location.html_hilight (loc,w); 
       print_exn ppf exn
   | Value.CDuceExn v ->
@@ -122,7 +122,7 @@ let rec print_exn ppf = function
 	Ident.print x
   | Ulexer.Error (i,j,s) ->
       let loc = Location.loc_of_pos (i,j), `Full in
-      Format.fprintf ppf "Error %a:@." Location.print_loc loc;
+      Location.print_loc ppf loc;
       Location.html_hilight loc;
       Format.fprintf ppf "%s" s
   | Parser.Error s | Stream.Error s -> 

driver/librarian.ml

@@ -88,9 +88,9 @@ let compile verbose name src =
   let p = 
     try Parser.prog input 
     with
-      | Stdpp.Exc_located (_, (Location _ as e)) -> raise e
+      | Stdpp.Exc_located (_, (Location _ | Ulexer.Error _ as e)) -> raise e
       | Stdpp.Exc_located ((i,j), e) -> 
-	raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
+	  raise_loc i.Lexing.pos_cnum j.Lexing.pos_cnum e
   in
   if src <> "" then close_in ic;
 

driver/run.ml

@@ -121,12 +121,14 @@ let toploop () =
   Sys.catch_break true;
   Cduce.toplevel := true;
   Librarian.run_loaded := true;
-  Location.push_source `Stream;
-  let read i =
+  let buf_in = Buffer.create 1024 in
+  Location.push_source (`Buffer buf_in);
+  let read _i =
     if !bol then 
       if !Ulexer.in_comment then outflush "* " else outflush "> ";
     try 
       let c = input_char stdin in
+      Buffer.add_char buf_in c;
       bol := c = '\n';
       Some c
     with Sys.Break -> quit () 
@@ -135,6 +137,7 @@ let toploop () =
   let rec loop () =
     outflush "# ";
     bol := false;
+    Buffer.clear buf_in;
     ignore (Cduce.topinput ppf ppf_err input);
     while (input_char stdin != '\n') do () done;
     loop () in

parser/location.ml

 (* TODO: handle encodings of the input for pretty printing
    fragments of code *)
 
-type source = [ `None | `File of string | `Stream | `String of string ]
+type source = [ `None | `File of string | `Stream | `String of string 
+	      | `Buffer of Buffer.t ]
 type loc = source * int * int
 type precise = [ `Full | `Char of int ]
 
@@ -43,13 +44,10 @@ let get_viewport () = !viewport
    The clean solution is probably to have the real lexer
    count the lines. *)
 
-let get_line_number src i =
-  let enc = ref Ulexing.Latin1 in
-  let ic = open_in_bin src in
-  let lb = Ulexing.from_var_enc_channel enc ic in
+let get_line_start enc lb i =
   let rec count line start = lexer
     | '\n' | "\n\r" | '\r' ->
-	if (Ulexing.lexeme_start lb >= i) then (line, i - start)
+	if (Ulexing.lexeme_start lb >= i) then (line, start)
 	else
 	aux (line + 1) (Ulexing.lexeme_end lb)
     | "#utf8" ->
@@ -62,35 +60,49 @@ let get_line_number src i =
 	enc := Ulexing.Latin1;
 	aux line start
     | eof ->
-	(line, i - start)
+	(line, start)
     | _ ->
 	aux line start
   and aux line start =
-    if (Ulexing.lexeme_start lb >= i) then (line, i - start)
+    if (Ulexing.lexeme_start lb >= i) then (line, start)
     else count line start lb
   in
-  let r = aux 1 0 in
+  aux 1 0
+
+let get_line_number src i =
+  let enc = ref Ulexing.Latin1 in
+  let ic = open_in_bin src in
+  let lb = Ulexing.from_var_enc_channel enc ic in
+  let r = get_line_start enc lb i in
   close_in ic;
   r
 
+let get_line_number_str src i =
+  let enc = ref Ulexing.Latin1 in
+  let lb = Ulexing.from_var_enc_string enc src in
+  get_line_start enc lb i
+
 let print_precise ppf = function
   | `Full -> ()
-  | `Char i -> Format.fprintf ppf " (char # %i)" i
+  | `Char i -> Format.fprintf ppf "Char %i of the string:@\n" i
 
 let print_loc ppf ((src,i,j),w) =  
   match src with
-    | `None -> Format.fprintf ppf "somewhere (no source defined !)"
+    | `None -> () (*Format.fprintf ppf "somewhere (no source defined !)"*)
     | `Stream | `String _ ->
-	Format.fprintf ppf "at chars %i-%i%a" i j print_precise w
+	Format.fprintf ppf "At chars %i-%i:@\n%a" i j print_precise w
+    | `Buffer b ->
+	let b = Buffer.contents b in
+	let (l1,start1) = get_line_number_str b i in
+	Format.fprintf ppf "Line %i, characters %i-%i:@\n%a"
+	  l1 (i - start1) (j - start1)
+	  print_precise w
+
     | `File fn ->
-	let (l1,c1) = get_line_number fn i
-	and (l2,c2) = get_line_number fn j in
-	if l1 = l2 then
-	  Format.fprintf ppf "at line %i (chars %i-%i)%a, file %s"
-	    l1 c1 c2 print_precise w fn
-	else
-	  Format.fprintf ppf "at lines %i (char %i) - %i (char %i)%a, file %s"
-	    l1 c1 l2 c2 print_precise w fn
+	let (l1,start1) = get_line_number fn i in
+	Format.fprintf ppf "File \"%s\", line %i, characters %i-%i:@\n%a"
+	  fn l1 (i - start1) (j - start1)
+	  print_precise w
 
 let extr s i j =
   try

parser/location.mli

 (* Locations in source file,
    and presentation of results and errors *)
 
-type source = [ `None | `File of string | `Stream | `String of string ]
+type source = 
+    [ `None | `File of string | `Stream | `String of string 
+    | `Buffer of Buffer.t ]
+
 type loc = source * int * int
 type precise = [ `Full | `Char of int ]
 
 exception Location of loc * precise * exn
 exception Generic of string
+
 val noloc:loc
 val nopos:int * int
 

typing/typer.ml

@@ -11,9 +11,9 @@ let (>) (x:int) y = x > y
 let warning loc msg =
   let v = Location.get_viewport () in
   let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
-  Format.fprintf ppf "Warning %a:@\n" Location.print_loc (loc,`Full);
+  Location.print_loc ppf (loc,`Full);
   Location.html_hilight (loc,`Full);
-  Format.fprintf ppf "%s@." msg
+  Format.fprintf ppf "Warning: %s@." msg
 
 exception NonExhaustive of Types.descr
 exception Constraint of Types.descr * Types.descr