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

5
6
7
8
let merge_loc ((s1,i1,j1) as loc1) (s2,i2,j2) =
  if s1 = s2 then (s1, min i1 i2, max j1 j2)
  else loc1

9
10
11
12
13
14
15
16
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

17
18
let warning_ppf = ref Format.std_formatter

19
exception Location of loc * exn
20
exception Generic of string
21

22
let raise_loc i j exn = raise (Location ((!source,i,j),exn))
23
24
25
let raise_generic s = raise (Generic s)
let raise_loc_generic loc s = raise (Location (loc, Generic s))

26
27
let noloc = (`None,-1,-1)
let nopos = (-1,-1)
28

29
30
31
let viewport = ref `Text
let set_viewport v = viewport := v

32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
46

47
48
let print_loc ppf (src,i,j) =  
  match src with
49
50
51
52
53
54
55
    | `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
56
57
	  Format.fprintf ppf "at line %i (chars %i-%i), file %s"
	    l1 c1 c2 fn
58
	else
59
60
	  Format.fprintf ppf "at lines %i (char %i) - %i (char %i), file %s"
	    l1 c1 l2 c2 fn
61

62
let extr s i j =
63
64
  Netencoding.Html.encode_from_latin1 
    (String.sub s i (j - i))
65

66
67
let dump_loc ppf (src,i,j) =
  match (src, !viewport) with
68
69
    | (`String s, `Html) ->
	if (i < 0) then
70
	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
71
	else
72
	  Format.fprintf ppf "<i>%s</i>@." (extr s i j)
73
74
75
    | _ -> ()

let rec beg_of_line s i =
76
77
  if (i = 0) || (s.[i-1] = '\n') || (s.[i-1] = '\r')
  then i else beg_of_line s (i - 1)
78
79

let rec end_of_line s i =
80
81
  if (i = String.length s) || (s.[i] = '\n') || (s.[i] = '\r')
  then i else end_of_line s (i + 1)
82

83
84
let html_hilight ppf (src,i,j) =
  match (src, !viewport) with
85
    | `String s, `Html ->
86
87
88
	if (i < 0) then
	  Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
	else
89
90
91
	let i0 = beg_of_line s i in
	let j0 = end_of_line s j in
	Format.fprintf ppf 
92
	  "<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@." 
93
94
95
96
97
98
	    (extr s i0 i)
	    (extr s i j)
	    (extr s j j0)
    | _ -> ()
	

99
100
type 'a located = { loc : loc; descr : 'a }

101
102
103
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 }
104
let loc_of_pos (i,j) = (!source,i,j)
105

106
let protect ppf f =
107
108
  match !viewport with
    | `Html ->
109
110
111
112
113
114
	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
115
	Format.fprintf ppf "@[%s@]" s
116
    | _ -> f ppf
117
118
119
120
121
122
123
124
125
126
127



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