cduce_loc.ml 5.15 KB
Newer Older
1 2 3
(* TODO: handle encodings of the input for pretty printing
   fragments of code *)

4 5
type source = [ `None | `File of string | `Stream | `String of string 
	      | `Buffer of Buffer.t ]
6
type loc = source * int * int
7 8
type precise = [ `Full | `Char of int ]

9 10 11 12
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 
      (s1, min i1 i2, max j1 j2)
13 14
  else loc1

15
let source = ref `None
16
let get_source () = !source
17 18 19 20 21 22 23
let source_stack = ref []
let push_source s = source_stack := !source :: !source_stack; source := s
let pop_source () = 
  match !source_stack with
    | [] -> assert false
    | s::rem -> source_stack := rem; source := s

24 25 26 27 28
let current_dir () =
  match !source with
    | `File s -> Filename.dirname s
    | _ -> ""

29
exception Location of loc * precise * exn
30
exception Generic of string
31

32
let raise_loc i j exn = raise (Location ((!source,i,j),`Full,exn))
33
let raise_generic s = raise (Generic s)
34
let raise_loc_generic loc s = raise (Location (loc, `Full, Generic s))
35

36 37
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
38

39 40 41
let viewport = ref (Html.create false)
let set_viewport v = viewport := v
let get_viewport () = !viewport
42

43 44 45 46 47
(* Note: this is incorrect. Directives #utf8,... should
   not be recognized inside comments and strings !
   The clean solution is probably to have the real lexer
   count the lines. *)

48
let get_line_start enc lb i =
49 50
  let rec count line start = lexer
    | '\n' | "\n\r" | '\r' ->
51
	if (Ulexing.lexeme_start lb >= i) then (line, start)
52
	else
53 54 55 56 57 58 59 60 61 62
	aux (line + 1) (Ulexing.lexeme_end lb)
    | "#utf8" ->
	enc := Ulexing.Utf8;
	aux line start
    | "#ascii" ->
	enc := Ulexing.Ascii;
	aux line start
    | "#latin1" ->
	enc := Ulexing.Latin1;
	aux line start
63
    | eof ->
64
	(line, start)
65 66 67
    | _ ->
	aux line start
  and aux line start =
68
    if (Ulexing.lexeme_start lb >= i) then (line, start)
69
    else count line start lb
70
  in
71 72 73 74 75 76 77
  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
78 79
  close_in ic;
  r
80

81 82 83 84 85
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

86 87
let print_precise ppf = function
  | `Full -> ()
88
  | `Char i -> Format.fprintf ppf "Char %i of the string:@\n" i
89 90

let print_loc ppf ((src,i,j),w) =  
91
  match src with
92
    | `None -> () (*Format.fprintf ppf "somewhere (no source defined !)"*)
93
    | `Stream | `String _ ->
94 95
	Format.fprintf ppf "At chars %i-%i:@\n%a" i j print_precise w
    | `Buffer b ->
96 97 98 99
(*	let b = Buffer.contents b in
	let (l1,start1) = get_line_number_str b i in *)
	Format.fprintf ppf "Characters %i-%i:@\n%a"
	  i j
100 101
	  print_precise w

102
    | `File fn ->
103 104 105 106
	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
107

108
let extr s i j =
109
  try
110
    let n = min (String.length s) j - i in
111
    if n <= 0 then "" else String.sub s i n
112
  with e -> failwith (Printf.sprintf "Cduce_loc.extr len=%i i=%i j=%i"
113
			(String.length s) i j )
114

115 116 117 118
let dump_loc ((src,i,j),w) =
  let v = get_viewport () in
  match (src, Html.is_html v) with
    | (`String s, true) ->
119
	if (i < 0) then
120
	  Html.markup v "b" (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
121
	else
122
	  Html.markup v "i" (fun ppf -> Format.fprintf ppf "%s" (extr s i j))
123 124 125
    | _ -> ()

let rec beg_of_line s i =
126
  if (i <= 0) || (s.[i-1] = '\n') || (s.[i-1] = '\r')
127
  then i else beg_of_line s (i - 1)
128 129

let rec end_of_line s i =
130
  if (i >= String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
131
  then i else end_of_line s (i + 1)
132

133 134 135 136
let html_hilight ((src,i,j),w) =
  let v = get_viewport () in
  match (src, Html.is_html v) with
    | `String s, true ->
137
	if (i < 0) then
138 139
	  Html.markup v "b" 
	    (fun ppf -> Format.fprintf ppf "GHOST LOCATION@.")
140
	else
141 142 143 144 145 146 147 148 149 150
	  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);
	    )
151 152 153
    | _ -> ()
	

154 155
type 'a located = { loc : loc; descr : 'a }

156
let mk_located (i,j) x = { loc = (!source,i,j); descr = x }
157 158
let mk_loc loc x = { loc = loc; descr = x }
let mknoloc x = { loc = noloc; descr = x }
159
let loc_of_pos (i,j) = (!source,i,j)
160

161 162 163 164 165 166 167 168
let protected = ref false
let set_protected p = protected := p
let is_protected () = !protected

let protect_op op =
  if (!protected) then
    raise 
      (Generic (op ^ ": operation not authorized in the web prototype"))
169 170 171 172 173 174 175 176 177 178 179 180 181

let obj_path = ref [ "" ]

let resolve_filename s =
  if Filename.is_relative s then
    try
      let p = 
	List.find 
	  (fun p -> Sys.file_exists (Filename.concat p s)) 
	  (current_dir () :: !obj_path) in
      Filename.concat p s
    with Not_found -> s
  else s
182 183 184

include Camlp4.PreCast.Loc

185 186 187 188 189 190
let warning loc msg =
  let v = get_viewport () in
  let ppf = if Html.is_html v then Html.ppf v else Format.err_formatter in
  print_loc ppf (loc,`Full);
  html_hilight (loc,`Full);
  Format.fprintf ppf "Warning: %s@." msg