| 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 |
let set_source s = source := s
|
| 12 |
|
| 13 |
let viewport = ref `Text
|
| 14 |
let set_viewport v = viewport := v
|
| 15 |
|
| 16 |
let get_line_number src i =
|
| 17 |
let ic = open_in_bin src in
|
| 18 |
let rec aux pos line start =
|
| 19 |
if (pos >= i)
|
| 20 |
then (line,i - start)
|
| 21 |
else
|
| 22 |
match input_char ic with
|
| 23 |
| '\r' when pos = start -> aux (pos + 1) line (pos + 1)
|
| 24 |
| '\r' | '\n' -> aux (pos + 1) (line + 1) (pos + 1)
|
| 25 |
| _ -> aux (pos + 1) line start
|
| 26 |
in
|
| 27 |
let r = aux 0 1 0 in
|
| 28 |
close_in ic;
|
| 29 |
r
|
| 30 |
|
| 31 |
let print_loc ppf (i,j) =
|
| 32 |
match !source with
|
| 33 |
| `None -> Format.fprintf ppf "somewhere (no source defined !)"
|
| 34 |
| `Stream | `String _ ->
|
| 35 |
Format.fprintf ppf "at chars %i-%i" i j
|
| 36 |
| `File fn ->
|
| 37 |
let (l1,c1) = get_line_number fn i
|
| 38 |
and (l2,c2) = get_line_number fn j in
|
| 39 |
if l1 = l2 then
|
| 40 |
Format.fprintf ppf "at line %i (chars %i-%i)"
|
| 41 |
l1 c1 c2
|
| 42 |
else
|
| 43 |
Format.fprintf ppf "at lines %i (char %i) - %i (char %i)"
|
| 44 |
l1 c1 l2 c2
|
| 45 |
|
| 46 |
let extr s i j =
|
| 47 |
Netencoding.Html.encode_from_latin1 (String.sub s i (j - i))
|
| 48 |
|
| 49 |
let dump_loc ppf (i,j) =
|
| 50 |
match (!source, !viewport) with
|
| 51 |
| (`String s, `Html) ->
|
| 52 |
if (i < 0) then
|
| 53 |
Format.fprintf ppf "<b>DUMMY</b>@\n"
|
| 54 |
else
|
| 55 |
Format.fprintf ppf "<i>%s</i>@\n" (extr s i j)
|
| 56 |
| _ -> ()
|
| 57 |
|
| 58 |
let rec beg_of_line s i =
|
| 59 |
if (i = 0) || (s.[i-1] = '\n') then i else beg_of_line s (i - 1)
|
| 60 |
|
| 61 |
let rec end_of_line s i =
|
| 62 |
if (i = String.length s) || (s.[i] = '\n') then i else end_of_line s (i + 1)
|
| 63 |
|
| 64 |
let html_hilight ppf (i,j) =
|
| 65 |
match (!source, !viewport) with
|
| 66 |
| `String s, `Html ->
|
| 67 |
let i0 = beg_of_line s i in
|
| 68 |
let j0 = end_of_line s j in
|
| 69 |
Format.fprintf ppf
|
| 70 |
"<i>%s<font color=red><b>%s</b></font>%s</i>@."
|
| 71 |
(extr s i0 i)
|
| 72 |
(extr s i j)
|
| 73 |
(extr s j j0)
|
| 74 |
| _ -> ()
|
| 75 |
|
| 76 |
|
| 77 |
type 'a located = { loc : loc; descr : 'a }
|
| 78 |
|
| 79 |
type expr = A | B of expr located
|
| 80 |
|
| 81 |
let mk loc x = { loc = loc; descr = x }
|
| 82 |
|
| 83 |
|
| 84 |
let protect ppf f =
|
| 85 |
match !viewport with
|
| 86 |
| `Html ->
|
| 87 |
let b = Buffer.create 63 in
|
| 88 |
let ppf' = Format.formatter_of_buffer b in
|
| 89 |
f ppf';
|
| 90 |
Format.pp_print_flush ppf' ();
|
| 91 |
let s = Buffer.contents b in
|
| 92 |
let s = Netencoding.Html.encode_from_latin1 s in
|
| 93 |
Format.fprintf ppf "@[%s@]" s
|
| 94 |
| _ -> f ppf
|
Parent Directory
| 
Revision Log