viewcvs.cgi/parser/location.ml

type loc = int * int
type source = [ `None | `File of string | `Stream | `String of string ]
type viewport = [ `Html | `Text ]

exception Location of loc * exn
exception Generic of string

let raise_generic s = raise (Generic s)
let raise_loc_generic loc s = raise (Location (loc, Generic s))

let noloc = (-1,-1)

let source = ref `None
let set_source s = source := s

let viewport = ref `Text
let set_viewport v = viewport := v

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

let print_loc ppf (i,j) =  
  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

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>GHOST LOCATION</b>@\n"
        else
          Format.fprintf ppf "<i>%s</i>@." (extr s i j)
    | _ -> ()

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

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

let html_hilight ppf (i,j) =
  match (!source, !viewport) with
    | `String s, `Html ->
        if (i < 0) then
          Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
        else
        let i0 = beg_of_line s i in
        let j0 = end_of_line s j in
        Format.fprintf ppf 
          "<i>%s<font color=red><b>%s</b></font>%s</i>@." 
            (extr s i0 i)
            (extr s i j)
            (extr s j j0)
    | _ -> ()
        

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

type expr = A | B of expr located

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


let protect ppf f =
  match !viewport with
    | `Html ->
        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.fprintf ppf "@[%s@]" s
    | _ -> f ppf


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