lang_utils/source.ml

  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

type pos = {file : string; line : int; column : int}
type region = {left : pos; right : pos}
type ('a, 'b) annotated_phrase = {at : region; it : 'a; mutable note: 'b}
type 'a phrase = ('a, unit) annotated_phrase

module Pos_ord = struct
  type t = pos

  let compare l r =
    match compare l.file r.file with
    | 0 ->
      (match compare l.line r.line with
      | 0 -> compare l.column r.column
      | ord -> ord)
    | ord -> ord
end

module Region_ord = struct
  type t = region

  let compare l r =
    match Pos_ord.compare l.left r.left with
    | 0 -> Pos_ord.compare l.right r.right
    | ord -> ord
end

module Region_set = Set.Make (Region_ord)
module Region_map = Map.Make (Region_ord)

let annotate note it at = {it; at; note}
let (@@) it at = annotate () it at

(* Positions and regions *)

let no_pos = {file = ""; line = 0; column = 0}
let no_region = {left = no_pos; right = no_pos}

let span r1 r2 = {left = r1.left; right = r2.right}
let between r1 r2 = {left = r1.right; right = r2.left}

let string_of_pos pos =
  if pos.line = -1 then
    Printf.sprintf "0x%x" pos.column
  else
    string_of_int pos.line ^ "." ^ string_of_int (pos.column + 1)

let string_of_region r =
  if r.left.file = "" then "(unknown location)" else
  r.left.file ^ ":" ^ string_of_pos r.left ^
  (if r.right = r.left then "" else "-" ^ string_of_pos r.right)

(* read source code from region *)
let read_region_with_markers r =
  try
    let in_channel = open_in r.left.file in
    let rec skip_lines n =
      if n > 0 then begin
        ignore (input_line in_channel);
        skip_lines (n - 1)
      end
    in
    let mark_line line start_marker end_marker =
      let len = String.length line in
      match (start_marker, end_marker) with
      | (Some start_col, Some end_col) ->
          String.sub line 0 start_col ^ "**" ^
          String.sub line start_col (end_col - start_col) ^ "**" ^
          String.sub line end_col (len - end_col)
      | (Some start_col, None) ->
          String.sub line 0 start_col ^ "**" ^ String.sub line start_col (len - start_col)
      | (None, Some end_col) ->
          String.sub line 0 end_col ^ "**" ^ String.sub line end_col (len - end_col)
      | (None, None) -> line
    in
    let rec read_lines start_line end_line acc =
      if start_line > end_line then
        String.concat "\n" (List.rev acc)
      else
        let line = input_line in_channel in
        let marked_line =
          if start_line = r.left.line && start_line = r.right.line then
            mark_line line (Some r.left.column) (Some r.right.column)
          else if start_line = r.left.line then
            mark_line line (Some r.left.column) None
          else if start_line = r.right.line then
            mark_line line None (Some r.right.column)
          else
            line
        in
        read_lines (start_line + 1) end_line (marked_line :: acc)
    in
    skip_lines (r.left.line - 1);
    let result = read_lines r.left.line r.right.line [] in
    close_in in_channel;
    Some result
  with e -> None

(* generic parse error *)

exception ParseError of region * string