package archetype

  1. Overview
  2. Docs

Source file location.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
101
(* -------------------------------------------------------------------- *)
open Core
open Lexing

(* -------------------------------------------------------------------- *)
type t = {
  loc_fname : string;
  loc_start : int * int;
  loc_end   : int * int;
  loc_bchar : int;
  loc_echar : int;
}
and 'a loced = {
  plloc : t;
  pldesc : 'a;
}
[@@deriving yojson, show {with_path = false},
 visitors { variety = "map"; name = "location_map"; polymorphic = true },
 visitors { variety = "iter"; name = "location_iter"; polymorphic = true },
 visitors { variety = "reduce"; name = "location_reduce"; polymorphic = true },
 visitors { variety = "reduce2"; name = "location_reduce2"; polymorphic = true }
]

let dummy : t = {
  loc_fname = "";
  loc_start = (-1, -1);
  loc_end   = (-1, -1);
  loc_bchar = -1;
  loc_echar = -1;
}

(* -------------------------------------------------------------------- *)
let make (p1 : position) (p2 : position) =
  let mkpos (p : position) =
    (p.pos_lnum, p.pos_cnum - p.pos_bol)
  in
  { loc_fname = p1.pos_fname;
    loc_start = mkpos p1    ;
    loc_end   = mkpos p2    ;
    loc_bchar = p1.pos_cnum ;
    loc_echar = p2.pos_cnum ; }

let of_lexbuf (lb : lexbuf) =
  let p1 = Lexing.lexeme_start_p lb in
  let p2 = Lexing.lexeme_end_p lb in
  make p1 p2

(* --------------------------------------------------------------------- *)
let merge (p1 : t) (p2 : t) =
  { loc_fname = p1.loc_fname;
    loc_start = min p1.loc_start p2.loc_start;
    loc_end   = max p1.loc_end   p2.loc_end  ;
    loc_bchar = min p1.loc_bchar p2.loc_bchar;
    loc_echar = max p1.loc_echar p2.loc_echar; }

let mergeall (p : t list) =
  match p with
  | []      -> dummy
  | t :: ts -> List.fold_left merge t ts

let isdummy (p : t) =
  p.loc_bchar < 0 || p.loc_echar < 0

(* --------------------------------------------------------------------- *)
let tostring (p : t) =
  let spos =
    if p.loc_start = p.loc_end then
      Printf.sprintf "line %d (%d)"
        (fst p.loc_start) (snd p.loc_start)
    else if fst p.loc_start = fst p.loc_end then
      Printf.sprintf "line %d (%d-%d)"
        (fst p.loc_start) (snd p.loc_start) (snd p.loc_end)
    else
      Printf.sprintf "line %d (%d) to line %d (%d)"
        (fst p.loc_start) (snd p.loc_start)
        (fst p.loc_end  ) (snd p.loc_end  )
  in

  if p.loc_fname <> "" then
    Printf.sprintf "%s: %s" p.loc_fname spos
  else
    spos

(* -------------------------------------------------------------------- *)
let pp_loced pp fmt (x : 'a loced) = Format.fprintf fmt "%a" pp x.pldesc

let loc    x = x.plloc
let unloc  x = x.pldesc
let unlocs x = List.map unloc x
let aspair x = (loc x, unloc x)

let lmap (f : 'a -> 'b) (x : 'a loced) =
  { x with pldesc = f x.pldesc }

let mkloc loc (x : 'a) : 'a loced =
  { plloc = loc; pldesc = x; }

let dumloc (x : 'a) : 'a loced =
  mkloc dummy x

let deloc x = x.plloc, x.pldesc