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

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

8
type viewport = [ `Html | `Text ]
9

10
11
12
13
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)
14
15
  else loc1

16
17
18
19
20
21
22
23
let source = ref `None
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
30
let warning_ppf = ref Format.std_formatter

31
exception Location of loc * precise * exn
32
exception Generic of string
33

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

38
39
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
40

41
42
43
let viewport = ref `Text
let set_viewport v = viewport := v

44
45
46
47
48
(* 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. *)

49
let get_line_number src i =
50
  let enc = ref Ulexing.Latin1 in
51
  let ic = open_in_bin src in
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
  let lb = Ulexing.from_var_enc_channel enc ic in
  let rec count line start = lexer
    | '\n' | "\n\r" | '\r' ->
	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
    | _ ->
	aux line start
  and aux line start =
    if (Ulexing.lexeme_start lb >= i) then (line, i - start)
    else count line start lb
70
  in
71
  let r = aux 1 0 in
72
73
  close_in ic;
  r
74

75
76
77
78
79
let print_precise ppf = function
  | `Full -> ()
  | `Char i -> Format.fprintf ppf " (char # %i)" i

let print_loc ppf ((src,i,j),w) =  
80
  match src with
81
82
    | `None -> Format.fprintf ppf "somewhere (no source defined !)"
    | `Stream | `String _ ->
83
	Format.fprintf ppf "at chars %i-%i%a" i j print_precise w
84
85
86
87
    | `File fn ->
	let (l1,c1) = get_line_number fn i
	and (l2,c2) = get_line_number fn j in
	if l1 = l2 then
88
89
	  Format.fprintf ppf "at line %i (chars %i-%i)%a, file %s"
	    l1 c1 c2 print_precise w fn
90
	else
91
92
	  Format.fprintf ppf "at lines %i (char %i) - %i (char %i)%a, file %s"
	    l1 c1 l2 c2 print_precise w fn
93

94
let extr s i j =
95
96
97
98
  try
    Netencoding.Html.encode_from_latin1 
      (String.sub s i (j - i))
  with e -> failwith "Location.extr"
99

100
let dump_loc ppf ((src,i,j),w) =
101
  match (src, !viewport) with
102
103
    | (`String s, `Html) ->
	if (i < 0) then
104
	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
105
	else
106
	  Format.fprintf ppf "<i>%s</i>@." (extr s i j)
107
108
109
    | _ -> ()

let rec beg_of_line s i =
110
  if (i <= 0) || (s.[i-1] = '\n') || (s.[i-1] = '\r')
111
  then i else beg_of_line s (i - 1)
112
113

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

117
let html_hilight ppf ((src,i,j),w) =
118
  match (src, !viewport) with
119
    | `String s, `Html ->
120
	(try 
121
122
123
	if (i < 0) then
	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
	else
124
125
126
	let i0 = beg_of_line s i in
	let j0 = end_of_line s j in
	Format.fprintf ppf 
127
	  "<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@." 
128
129
130
	    (extr s i0 i)
	    (extr s i j)
	    (extr s j j0)
131
	with e -> failwith "html_hilight")
132
133
134
    | _ -> ()
	

135
136
type 'a located = { loc : loc; descr : 'a }

137
138
139
let mk (i,j) x = { loc = (!source,i,j); descr = x }
let mk_loc loc x = { loc = loc; descr = x }
let mknoloc x = { loc = noloc; descr = x }
140
let loc_of_pos (i,j) = (!source,i,j)
141

142
let protect ppf f =
143
144
  match !viewport with
    | `Html ->
145
146
147
148
149
150
	let b = Buffer.create 63 in
	let ppf' = Format.formatter_of_buffer b in
	f ppf';
	Format.pp_print_flush ppf' ();
	let s = Buffer.contents b in
	let s = Netencoding.Html.encode_from_latin1 s in
151
	Format.fprintf ppf "@[%s@]" s
152
    | _ -> f ppf
153
154
155
156
157
158
159
160
161
162
163



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"))