positions.ml 3.72 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
(******************************************************************************)
(*                                                                            *)
(*                                   Menhir                                   *)
(*                                                                            *)
(*                       François Pottier, Inria Paris                        *)
(*              Yann Régis-Gianas, PPS, Université Paris Diderot              *)
(*                                                                            *)
(*  Copyright Inria. All rights reserved. This file is distributed under the  *)
(*  terms of the GNU General Public License version 2, as described in the    *)
(*  file LICENSE.                                                             *)
(*                                                                            *)
(******************************************************************************)

14 15
open Lexing

16
type t =
17 18
  (* Start and end positions. *)
  position * position
19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37

type 'a located =
    {
      value    : 'a;
      position : t;
    }

let value { value = v } =
  v

let position { position = p } =
  p

let with_pos p v =
  {
    value     = v;
    position  = p;
  }

38 39 40 41
let with_loc =
  (* The location is converted from the type [position * position]
     to the type [t]. *)
  with_pos
42 43 44 45 46 47 48

let map f v =
  {
    value     = f v.value;
    position  = v.position;
  }

49 50 51 52 53 54
let pmap f v =
  {
    value     = f v.position v.value;
    position  = v.position
  }

55 56 57 58 59 60 61 62 63
let iter f { value = v } =
  f v

let mapd f v =
  let w1, w2 = f v.value in
  let pos = v.position in
  { value = w1; position = pos },
  { value = w2; position = pos }

64
let dummy =
65
  (dummy_pos, dummy_pos)
66

67
let unknown_pos v =
68 69 70 71 72
  {
    value     = v;
    position  = dummy
  }

73
let start_of_position (p, _) = p
74

75
let end_of_position (_, p) = p
76

77
let filename_of_position p =
78
  (start_of_position p).pos_fname
79 80 81 82 83 84 85 86 87 88 89

let line p =
  p.pos_lnum

let column p =
  p.pos_cnum - p.pos_bol

let characters p1 p2 =
  (column p1, p2.pos_cnum - p1.pos_bol) (* intentionally [p1.pos_bol] *)

let join x1 x2 =
90 91 92 93
(
  start_of_position (if x1 = dummy then x2 else x1),
  end_of_position   (if x2 = dummy then x1 else x2)
)
94

95 96
let import x =
  x
97

98
let join_located l1 l2 f =
99 100 101 102 103
  {
    value    = f l1.value l2.value;
    position = join l1.position l2.position;
  }

104
let string_of_lex_pos p =
105 106 107
  let c = p.pos_cnum - p.pos_bol in
  (string_of_int p.pos_lnum)^":"^(string_of_int c)

108
let string_of_pos p =
109
  let filename = filename_of_position p in
110
  (* [filename] is hopefully not "". *)
111 112
  let l = line (start_of_position p) in
  let c1, c2 = characters (start_of_position p) (end_of_position p) in
113 114 115 116 117 118 119
  Printf.sprintf "File \"%s\", line %d, characters %d-%d" filename l c1 c2

let pos_or_undef = function
  | None -> dummy
  | Some x -> x

let cpos lexbuf =
120
  (lexeme_start_p lexbuf, lexeme_end_p lexbuf)
121 122 123 124

let with_cpos lexbuf v =
  with_pos (cpos lexbuf) v

125
let string_of_cpos lexbuf =
126 127
  string_of_pos (cpos lexbuf)

128
let joinf f t1 t2 =
129 130 131 132 133
  join (f t1) (f t2)

let ljoinf f =
  List.fold_left (fun p t -> join p (f t)) dummy

134
let join_located_list ls f =
135 136 137 138 139 140 141 142 143 144 145
  {
    value     = f (List.map (fun l -> l.value) ls);
    position  = ljoinf (fun x -> x.position) ls
  }

(* The functions that print error messages and warnings require a list of
   positions. The following auxiliary functions help build such lists. *)

type positions =
    t list

146
let one (pos : position) : positions =
147
  [ import (pos, pos) ]
148

149
let lexbuf (lexbuf : lexbuf) : positions =
150
  [ import (lexbuf.lex_start_p, lexbuf.lex_curr_p) ]
151

152
let print (pos : position) =
153 154 155 156 157 158
  Printf.printf
    "{ pos_fname = \"%s\"; pos_lnum = %d; pos_bol = %d; pos_cnum = %d }\n"
      pos.pos_fname
      pos.pos_lnum
      pos.pos_bol
      pos.pos_cnum