Skip to content
This repository
tag: v1067
Fetching contributors…

Cannot retrieve contributors at this time

file 536 lines (451 sloc) 16.842 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 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 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF MLI *)

module Format = BaseFormat
module List = BaseList

(* alias type *)

type filename = string
type content = string
type absolute_char_offset = int
type line_number = int
type column_number = int


(* cache mechanisme *)

(* memoize filename,content,offsetmap (first line char -> line)
globally to retrieve easily information from file on errors *)

let parsed_files : (string, (string * int IntMap.t)) Hashtbl.t = Hashtbl.create 16

(* an other cache for having the reverse map *)
let reverse_parsed_files : (string, int array) Hashtbl.t = Hashtbl.create 16

let debug () =
  let iter file (_content, map) =
    Printf.printf "File %S\n" file;
    IntMap.iter (fun offset line -> Printf.printf "line %d -- global offset %d\n%!" line offset) map
  in
  Hashtbl.iter iter parsed_files

let get_file_content file =
  fst (Hashtbl.find parsed_files file)

let uncache file =
  Hashtbl.remove parsed_files file;
  Hashtbl.remove reverse_parsed_files file

let clear () =
  Hashtbl.clear parsed_files;
  Hashtbl.clear reverse_parsed_files

(* compute maps of previous structure *)
let rec compute_lines content pos line map =
  let len = String.length content in
  if pos < len then
    if
      content.[pos] = '\n' ||
      content.[pos] = '\r' && ( ( (pos<len-1) && content.[pos+1]<>'\n' ) ||
                                  ( (pos>1 ) && content.[pos-1]<>'\n' ) )
    then
      compute_lines content (pos+1) (line+1) (IntMap.add (pos+1) (line+1) map)
    else compute_lines content (pos+1) line map
  else map

(* add a file to the memoization *)
let add_file file content =
  let pos_line_map = compute_lines content 0 1 (IntMap.add 0 1 IntMap.empty) in
  Hashtbl.replace parsed_files file (content, pos_line_map)

(* get the line and column number from a char position for a given file *)
let get_line_char file i =
  let i = max 0 i in
  let get_line_char map i =
    let i_line, line_number = try IntMap.find_inf i map with Not_found -> (1,1) in
    let char_in_line = i - i_line in
    (line_number, char_in_line)
  in
  let _, map = Hashtbl.find parsed_files file in
  get_line_char map i

let get_pos filename offset =
  let getLine = get_line_char filename in
  getLine offset

let get_pos_string (line, column) =
  Printf.sprintf "line %d, column %d" line column

let get_line filename offset =
  let offset = max 0 offset in
  let line, col = get_pos filename offset in
  (* Printf.fprintf stdout "get_line %d -> %d (line %d)\n%!" offset (offset - col) line; *)
  offset-col, line

let get_next_line file i =
  let default = (1, 1) in
  try (
    let _, map = Hashtbl.find parsed_files file in
    try
      IntMap.find_sup i map
    with Not_found -> (
      try IntMap.find_inf i map
      with Not_found -> default
    )
  ) with Not_found -> default

let cache_reverse_map file array =
  Hashtbl.add reverse_parsed_files file array

let build_reverse_map map =
  let size = IntMap.size map in
  let t = Array.make size 0 in
  IntMap.iter (fun i j -> t.(pred j) <- i) map;
  t

let line_position file line =
  let lines =
    try
      Hashtbl.find reverse_parsed_files file
    with
    | Not_found ->
        (* this can also raise Not_found *)
        let _, map = Hashtbl.find parsed_files file in
        let array = build_reverse_map map in
        cache_reverse_map file array;
        array
  in
  let len = Array.length lines in
  if (1 <= line) && (line <= len)
  then
    let start = lines.(line-1) in
    if line < len
    then start, lines.(line)
    else start, start
  else raise Not_found

(* position tracking *)

type range = {
  start : absolute_char_offset ;
  stop : absolute_char_offset ;
}

type filerange = {
  filename : filename ;
  ranges : range HdList.t
}

type private_cache = {
  mutable one_loc : (filename * line_number) option ;
}

type pos =
  | Builtin of string
  | Files of filerange HdList.t * private_cache

let make_cache () = {
  one_loc = None ;
}

let nopos pass = Builtin pass
let get_file = function
  | Builtin pass -> Printf.sprintf "builtin_%s" pass
  | Files (hd, _) -> (HdList.hd hd).filename

let get_one_loc = function
  | Builtin pass -> Printf.sprintf "builtin_%s" pass, 0
  | Files (hd, cache) -> (
      match cache.one_loc with
      | Some loc -> loc
      | None ->
          let hd = HdList.hd hd in
          let filename = hd.filename in
          let start = (HdList.hd hd.ranges).start in
          let _, line = get_line filename start in
          let loc = filename, line in
          cache.one_loc <- Some loc ;
          loc
    )

let get_first_char = function
  | Builtin _ -> 0
  | Files ((f, _), _) -> (fst f.ranges).start

let make_pos filename start stop =
  if stop < start then invalid_arg "FilePos.make_pos" else
    let range = { start = start ; stop = stop } in
    Files (
      (HdList.singleton { filename = filename ; ranges = HdList.singleton range } ),
      make_cache ()
    )
let cmp (a, _) (b, _) = compare a b
let sort_pos = List.sort cmp

let make_pos_from_line file line =
  try
    let start, stop = line_position file line in
    let pos = make_pos file start stop in
    let () =
      match pos with
      | Files (_, cache) -> cache.one_loc <- Some (file, line)
      | _ -> ()
    in
    pos
  with
  | Not_found ->
      nopos (Printf.sprintf "File %S, line %d:" file line)

let merge_range {start = x1; stop = y1} {start = x2; stop = y2} =
  {start = min x1 x2; stop = max y1 y2}

let merge_pos_for_parser p1 p2 =
  match p1, p2 with
  | Files (({filename=filename1;ranges=(range1,[])},[]), _),
    Files (({filename=filename2;ranges=(range2,[])},[]), _) ->
      assert (filename1 = filename2);
      Files (
        ({filename=filename1; ranges = (merge_range range1 range2, [])}, []),
        make_cache()
      )
  | _ -> assert false

(* very bad complexity, but in practice the list are very little (less than 20 files) *)
module LH = ListHashtbl
let merge_pos p1 p2 =
  match p1, p2 with
  | Builtin _, a | a, Builtin _ -> a
  | Files (r, _), Files (r', _) -> (
      let lh = LH.create 10 in
      (* collect by filenames *)
      let iter f =
        let filename = f.filename in
        HdList.iter (fun r -> LH.add lh filename (r.start, r.stop)) f.ranges in
      HdList.iter iter r ;
      HdList.iter iter r';
      (* insertion of a segment in a segment list sorted by start *)
      let rec merge acc ((start, stop) as seg) =
        match acc with
        | [] -> [ seg ]
        | ((start', stop') as hd)::tl ->
            if start > stop' + 1 then hd::(merge tl seg)
            else
              if stop < start' - 1 then seg::acc
              else
                (min start start', max stop stop')::tl
      in
      let collect filename segs acc =
        let segs = List.fold_left merge [] segs in
        let ranges = List.fold_left (fun acc (start, stop) -> { start = start ; stop = stop } :: acc ) [] segs in
        { filename = filename ; ranges = HdList.wrap (List.rev ranges) } :: acc
      in
      let ranges = List.rev (LH.fold_list collect lh []) in
      Files ((HdList.wrap ranges), make_cache())
    )

let merge_pos_list = function
  | [] -> invalid_arg "FilePos.merge_pos_list"
  | h :: t -> List.fold_left merge_pos h t

let is_empty = function
  | Builtin _ -> true
  | _ -> false

let to_string_range filename r =
  let start = r.start in
  let stop = r.stop in
  try
    let line1, col1 = get_pos filename start in
    let line2, col2 = get_pos filename stop in
    (* Do not change the layout there, or update in the opa-mode the variable compilation-error-regexp-alist *)
    Printf.sprintf "File %S, line %d, characters %d-%d, (%d:%d-%d:%d | %d-%d)" filename line1 col1 (col1 + stop - start) line1 col1 line2 col2
      (#<If:TESTING> 0 #<Else> start #<End>)
      (#<If:TESTING> 0 #<Else> stop #<End>)
  with
  | Not_found ->
      Printf.sprintf "File %S (%d-%d)" filename start stop

let pp_filerange filename fmt r =
  Format.pp_print_string fmt (to_string_range filename r)

let pp_filerange fmt {filename=filename; ranges=ranges} =
  let ranges = HdList.unwrap ranges in
  Format.pp_list "@\n" (pp_filerange filename) fmt ranges

let pp_pos fmt = function
  | Builtin pass -> Format.fprintf fmt "<no position available (%s)>" pass
  | Files (files, _) ->
      let files = HdList.unwrap files in
      Format.pp_list "@\n" pp_filerange fmt files

let pp_files fmt = function
  | Builtin pass -> Format.fprintf fmt "<no file available (%s)>" pass
  | Files (files, _) ->
      let files = HdList.unwrap files in
      Format.pp_list ", " (fun fmt v -> Format.pp_print_string fmt v.filename) fmt files

let to_string_filerange f = Format.to_string pp_filerange f
let to_string p = Format.to_string pp_pos p

(* deprecated API *)
let to_old_pos_many = function
  | Builtin _ -> StringMap.empty
  | Files (fileranges, _) ->
      let translate {start = d; stop = f} = (d, f) in
      let fold map f =
        let file = f.filename in
        let r, ranges = f.ranges in
        let wrong = List.fold_left merge_range r ranges in
        StringMap.add file (translate wrong) map
      in
      HdList.fold_left fold StringMap.empty fileranges

let to_old_pos nopos = function
  | Builtin _ -> nopos ()
  | Files ((f, _), _) ->
      let r = fst f.ranges in
      f.filename, r.start, r.stop

(* citations *)

(*
The effeciency is not a goal, because we are just printing once a citation in case
of error. So, do not hack the code for unused optimisation, keep it rather simple.
*)

type options = {
  truncate_lines : int option ;
  lines_before : int ;
  lines_after : int ;
  lines_between : int ;
  color : Ansi.color option ;
  max_length_citation : int option ;
}

let default_options = {
  truncate_lines = Some 80 ;
  lines_before = 5 ;
  lines_after = 5 ;
  lines_between = 5 ;
  color = Some ( `red : Ansi.color ) ;
  max_length_citation = Some 200 ;
}

(* Shame : no Format.pp_print_string_sub ? *)
let pp_print_string_sub fmt content offset len = Format.pp_print_string fmt (String.sub content offset len)

let no_citation fmt pass =
  Format.fprintf fmt "%s (no-citation-available)@\n" pass

(* ALL THE FOLLOWING FUNCTIONS MAY RAISE NOT_FOUND, BUT THEY ARE ALL USED ONLY
INTERNALLY BY THE FUNCTION CITATION, WHICH CATCH THE EXCEPTION.
*)

(* this function return the global offset of the first char of the previous line of the line which contains the char offset *)
(*

called with the offset of m :

p
m

it returns the offset of p
*)
let predline_offset filename offset =
  let offset, _ = get_line filename offset in
  let offset, _ = get_line filename (pred offset) in
  offset

(* symetric *)
let succline_offset filename offset =
  let offset, _ = get_next_line filename (succ offset) in
  offset

(* compose predline or succ line, return the sorted offset of successive lines *)
let compose n line_offset filename offset =
  let rec aux acc offset i = if i >= n then acc else
    let offset = line_offset filename offset in
    aux (offset::acc) offset (succ i)
  in
  let row = aux [] offset 0 in
  List.uniq row

let predlines n = compose n predline_offset
let succlines n filename offset = List.rev (compose n succline_offset filename offset)

(* extract a line with a maximal allowed length, and print it into the formatter *)
(* The offsets list is a list of first char of line *)
let extract_lines options fmt filename offsets =
  let content = get_file_content filename in
  let iter_trunc trunc offset =
    let succline = succline_offset filename offset in
    let all = succline - offset in
    let line =
      match trunc with
      | Some trunc ->
          if all > trunc then (String.sub content offset trunc)^"[...]\n"
          else String.sub content offset all
      | None ->
          String.sub content offset all
    in
    Format.pp_print_string fmt line
  in
  try List.iter (iter_trunc options.truncate_lines) offsets
  with
  | Invalid_argument _ -> ()

(* print the right part of the string, including the index *)
let extract_right _options fmt filename offset =
  let noff = fst (get_next_line filename offset) in
  let noff = if noff = offset then fst (get_next_line filename (succ offset)) else noff in
  let content = get_file_content filename in
  Format.pp_print_string fmt (String.sub content offset (noff - offset))

(* print the left part of the line, excluding the index *)
let extract_left _options fmt filename offset =
  let _, col = get_pos filename offset in
  let content = get_file_content filename in
  Format.pp_print_string fmt (String.sub content (offset-col) col)

(* usefull to print between two points (the stop of a range, and the start of the next) *)
let extract_between options fmt filename pointA pointB =
  let lineA, _ = get_pos filename pointA in
  let lineB, _ = get_pos filename pointB in
  let content = get_file_content filename in
  if lineB - lineA > options.lines_between
  then (
    let n = options.lines_between / 2 in
    let succA = succlines n filename pointA in
    let predB = predlines n filename pointB in
    extract_right options fmt filename pointA ;
    extract_lines options fmt filename succA ;
    Format.pp_print_string fmt "[...]\n";
    extract_lines options fmt filename predB ;
    extract_left options fmt filename pointB
  )
  else
    pp_print_string_sub fmt content pointA (pointB-pointA)

(* First version : Print the citation with some color *)
let unsafe_citation_files options fmt filerange =
  let open_color, close_color =
    match options.color with
    | Some color -> Ansi.open_color_code color, Ansi.close_color_code
    | None -> "<<<", ">>>"
  in
  let filename = filerange.filename in

  Format.pp_print_string fmt (to_string_filerange filerange);
  Format.pp_print_char fmt '\n';

  let hdranges = filerange.ranges in
  let content = get_file_content filename in
  let first = HdList.hd hdranges in
  let last = HdList.last hdranges in

  let predlines = predlines options.lines_before filename first.start in
  let succlines = succlines options.lines_after filename last.stop in

  let offset_first, _ = get_line filename first.start in
  let predlines = List.filter (fun l -> l <> offset_first) predlines in
  let offset_last, _ = get_line filename last.stop in
  let succlines = List.filter (fun l -> l <> offset_last) succlines in

  Format.pp_print_string fmt "------citation-------\n" ;
  Format.pp_print_string fmt "---------------------\n" ;

  (* lines before *)
  extract_lines options fmt filename predlines;

  (* first part *)
  extract_left options fmt filename first.start ;

  (* Midle part *)
  (* common part *)
  let common r =
    let start = r.start in
    let stop = r.stop in
    Format.pp_print_string fmt open_color;
    pp_print_string_sub fmt content start (stop-start);
    Format.pp_print_string fmt close_color;
  in

  let rec iter ranges =
    match ranges with
    | hd::((hd2::_) as tl) ->
        common hd ;
        extract_between options fmt filename hd.stop hd2.start ;
        iter tl
    | [last] ->
        common last ;
        (* in the last case case, we should extract the right part *)
        extract_right options fmt filename last.stop
    | [] -> assert false
  in
  iter (HdList.unwrap hdranges) ;

  (* lines after *)
  extract_lines options fmt filename succlines ;
  Format.pp_print_char fmt '\n' ;

  Format.pp_print_string fmt "---------------------\n" ;
  Format.pp_print_string fmt "---end-of-citation---\n" ;

  ()

let citation_files options fmt filerange =
  try unsafe_citation_files options fmt filerange
  with Not_found -> no_citation fmt "<source file not available anymore>"

let citation ?(options=default_options) fmt pos =
  match pos with
  | Builtin pass -> no_citation fmt pass
  | Files (files, _) ->
      HdList.iter (citation_files options fmt) files

(* FIXME, consider re-implementing this function; it's
supposed to serve a single request so we don't have to
check line breaks after [pos]. *)
let get_pos_no_cache content pos =
  let id = ref 0 in
  let tmp_filename = Printf.sprintf "tmp-@%d@" !id in
  incr id;
  add_file tmp_filename content;
  let res = get_pos tmp_filename pos in
  uncache tmp_filename;
  res

let pp_citation fmt pos = citation fmt pos
let pp = pp_pos
Something went wrong with that request. Please try again.