location.ml 2.39 KB
Newer Older
1
type loc = int * int
2
type source = [ `None | `File of string | `Stream | `String of string ]
3
type viewport = [ `Html | `Text ]
4

5
exception Location of loc * exn
6
exception Generic of string
7
8

let noloc = (-1,-1)
9

10
let source = ref `None
11
12
let set_source s = source := s

13
14
15
let viewport = ref `Text
let set_viewport v = viewport := v

16
17
18
19
20
21
22
23
24
25
26
27
28
29
let get_line_number src i =
  let ic = open_in_bin src in
  let rec aux pos line start =
    if (pos >= i) 
    then (line,i - start) 
    else
      match input_char ic with
	| '\r' when pos = start -> aux (pos + 1) line (pos + 1)
	| '\r' | '\n' -> aux (pos + 1) (line + 1) (pos + 1)
	| _ -> aux (pos + 1) line start
  in
  let r = aux 0 1 0 in
  close_in ic;
  r
30
31

let print_loc ppf (i,j) =  
32
33
34
35
36
37
38
39
40
41
42
43
44
  match !source with
    | `None -> Format.fprintf ppf "somewhere (no source defined !)"
    | `Stream | `String _ ->
	Format.fprintf ppf "at chars %i-%i" i j
    | `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)"
	    l1 c1 c2
	else
	  Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
	    l1 c1 l2 c2
45

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
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 
70
	  "<i>%s<font color=red><b>%s</b></font>%s</i>@." 
71
72
73
74
75
76
	    (extr s i0 i)
	    (extr s i j)
	    (extr s j j0)
    | _ -> ()
	

77
78
79
80
81
type 'a located = { loc : loc; descr : 'a }

type expr = A | B of expr located

let mk loc x = { loc = loc; descr = x }
82
83


84
let protect ppf f =
85
86
  match !viewport with
    | `Html ->
87
88
89
90
91
92
93
94
	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
	Format.pp_print_string ppf s
    | _ -> f ppf
95
96
97
98
99

let outputr = ref Format.std_formatter
let output () = !outputr
let set_output f = outputr := f