viewcvs.cgi/parser/location.ml

(* TODO: handle encodings of the input for pretty printing
   fragments of code *)

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

type viewport = [ `Html | `Text ]

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)
  else loc1

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

let current_dir () =
  match !source with
    | `File s -> Filename.dirname s
    | _ -> ""

let warning_ppf = ref Format.std_formatter

exception Location of loc * precise * exn
exception Generic of string

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

let noloc = (`None,-1,-1)
let nopos = (-1,-1)

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

(* 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. *)

let get_line_number src i =
  let enc = ref Ulexing.Latin1 in
  let ic = open_in_bin src in
  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
    | eof ->
        (line, i - start)
    | _ ->
        aux line start
  and aux line start =
    if (Ulexing.lexeme_start lb >= i) then (line, i - start)
    else count line start lb
  in
  let r = aux 1 0 in
  close_in ic;
  r

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

let print_loc ppf ((src,i,j),w) =  
  match src with
    | `None -> Format.fprintf ppf "somewhere (no source defined !)"
    | `Stream | `String _ ->
        Format.fprintf ppf "at chars %i-%i%a" i j print_precise w
    | `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)%a, file %s"
            l1 c1 c2 print_precise w fn
        else
          Format.fprintf ppf "at lines %i (char %i) - %i (char %i)%a, file %s"
            l1 c1 l2 c2 print_precise w fn

let extr s i j =
  try
    Netencoding.Html.encode_from_latin1 
      (String.sub s i (j - i))
  with e -> failwith "Location.extr"

let dump_loc ppf ((src,i,j),w) =
  match (src, !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 ((src,i,j),w) =
  match (src, !viewport) with
    | `String s, `Html ->
        (try 
        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)
        with e -> failwith "html_hilight")
    | _ -> ()
        

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

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 }
let loc_of_pos (i,j) = (!source,i,j)

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	(* TODO: handle encodings of the input for pretty printing
2	fragments of code *)
3
4	type source = [ `None \| `File of string \| `Stream \| `String of string ]
5	type loc = source * int * int
6	type precise = [ `Full \| `Char of int ]
7
8	type viewport = [ `Html \| `Text ]
9
10	let merge_loc ((s1,i1,j1) as loc1) ((s2,i2,j2) as loc2) =
11	if s1 = s2 then
12	if i1 = -1 then loc2 else if i2 = -1 then loc1 else
13	(s1, min i1 i2, max j1 j2)
14	else loc1
15
16	let source = ref `None
17	let source_stack = ref []
18	let push_source s = source_stack := !source :: !source_stack; source := s
19	let pop_source () =
20	match !source_stack with
21	\| [] -> assert false
22	\| s::rem -> source_stack := rem; source := s
23
24	let current_dir () =
25	match !source with
26	\| `File s -> Filename.dirname s
27	\| _ -> ""
28
29	let warning_ppf = ref Format.std_formatter
30
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	let noloc = (`None,-1,-1)
39	let nopos = (-1,-1)
40
41	let viewport = ref `Text
42	let set_viewport v = viewport := v
43
44	(* Note: this is incorrect. Directives #utf8,... should
45	not be recognized inside comments and strings !
46	The clean solution is probably to have the real lexer
47	count the lines. *)
48
49	let get_line_number src i =
50	let enc = ref Ulexing.Latin1 in
51	let ic = open_in_bin src in
52	let lb = Ulexing.from_var_enc_channel enc ic in
53	let rec count line start = lexer
54	\| '\n' \| "\n\r" \| '\r' ->
55	aux (line + 1) (Ulexing.lexeme_end lb)
56	\| "#utf8" ->
57	enc := Ulexing.Utf8;
58	aux line start
59	\| "#ascii" ->
60	enc := Ulexing.Ascii;
61	aux line start
62	\| "#latin1" ->
63	enc := Ulexing.Latin1;
64	aux line start
65	\| eof ->
66	(line, i - start)
67	\| _ ->
68	aux line start
69	and aux line start =
70	if (Ulexing.lexeme_start lb >= i) then (line, i - start)
71	else count line start lb
72	in
73	let r = aux 1 0 in
74	close_in ic;
75	r
76
77	let print_precise ppf = function
78	\| `Full -> ()
79	\| `Char i -> Format.fprintf ppf " (char # %i)" i
80
81	let print_loc ppf ((src,i,j),w) =
82	match src with
83	\| `None -> Format.fprintf ppf "somewhere (no source defined !)"
84	\| `Stream \| `String _ ->
85	Format.fprintf ppf "at chars %i-%i%a" i j print_precise w
86	\| `File fn ->
87	let (l1,c1) = get_line_number fn i
88	and (l2,c2) = get_line_number fn j in
89	if l1 = l2 then
90	Format.fprintf ppf "at line %i (chars %i-%i)%a, file %s"
91	l1 c1 c2 print_precise w fn
92	else
93	Format.fprintf ppf "at lines %i (char %i) - %i (char %i)%a, file %s"
94	l1 c1 l2 c2 print_precise w fn
95
96	let extr s i j =
97	try
98	Netencoding.Html.encode_from_latin1
99	(String.sub s i (j - i))
100	with e -> failwith "Location.extr"
101
102	let dump_loc ppf ((src,i,j),w) =
103	match (src, !viewport) with
104	\| (`String s, `Html) ->
105	if (i < 0) then
106	Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
107	else
108	Format.fprintf ppf "<i>%s</i>@." (extr s i j)
109	\| _ -> ()
110
111	let rec beg_of_line s i =
112	if (i <= 0) \|\| (s.[i-1] = '\n') \|\| (s.[i-1] = '\r')
113	then i else beg_of_line s (i - 1)
114
115	let rec end_of_line s i =
116	if (i >= String.length s) \|\| (s.[i] = '\n') \|\| (s.[i] = '\r')
117	then i else end_of_line s (i + 1)
118
119	let html_hilight ppf ((src,i,j),w) =
120	match (src, !viewport) with
121	\| `String s, `Html ->
122	(try
123	if (i < 0) then
124	Format.fprintf ppf "<b>GHOST LOCATION</b>@\n"
125	else
126	let i0 = beg_of_line s i in
127	let j0 = end_of_line s j in
128	Format.fprintf ppf
129	"<i>%s<font color=\"red\"><b>%s</b></font>%s</i>@."
130	(extr s i0 i)
131	(extr s i j)
132	(extr s j j0)
133	with e -> failwith "html_hilight")
134	\| _ -> ()
135
136
137	type 'a located = { loc : loc; descr : 'a }
138
139	let mk (i,j) x = { loc = (!source,i,j); descr = x }
140	let mk_loc loc x = { loc = loc; descr = x }
141	let mknoloc x = { loc = noloc; descr = x }
142	let loc_of_pos (i,j) = (!source,i,j)
143
144	let protect ppf f =
145	match !viewport with
146	\| `Html ->
147	let b = Buffer.create 63 in
148	let ppf' = Format.formatter_of_buffer b in
149	f ppf';
150	Format.pp_print_flush ppf' ();
151	let s = Buffer.contents b in
152	let s = Netencoding.Html.encode_from_latin1 s in
153	Format.fprintf ppf "@[%s@]" s
154	\| _ -> f ppf
155
156
157
158	let protected = ref false
159	let set_protected p = protected := p
160	let is_protected () = !protected
161
162	let protect_op op =
163	if (!protected) then
164	raise
165	(Generic (op ^ ": operation not authorized in the web prototype"))