positions.ml 3.63 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

POTTIER Francois's avatar
POTTIER Francois committed
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 49 50 51 52 53 54 55 56 57

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

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 }

POTTIER Francois's avatar
POTTIER Francois committed
58
let dummy =
59
  (dummy_pos, dummy_pos)
60

POTTIER Francois's avatar
POTTIER Francois committed
61
let unknown_pos v =
62 63 64 65 66
  {
    value     = v;
    position  = dummy
  }

67
let start_of_position (p, _) = p
68

69
let end_of_position (_, p) = p
70

POTTIER Francois's avatar
POTTIER Francois committed
71
let filename_of_position p =
72
  (start_of_position p).pos_fname
73 74 75 76 77 78 79 80 81 82 83

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 =
84 85 86 87
(
  start_of_position (if x1 = dummy then x2 else x1),
  end_of_position   (if x2 = dummy then x1 else x2)
)
88

89 90
let import x =
  x
91

POTTIER Francois's avatar
POTTIER Francois committed
92
let join_located l1 l2 f =
93 94 95 96 97
  {
    value    = f l1.value l2.value;
    position = join l1.position l2.position;
  }

POTTIER Francois's avatar
POTTIER Francois committed
98
let string_of_lex_pos p =
99 100 101
  let c = p.pos_cnum - p.pos_bol in
  (string_of_int p.pos_lnum)^":"^(string_of_int c)

POTTIER Francois's avatar
POTTIER Francois committed
102
let string_of_pos p =
103
  let filename = filename_of_position p in
104
  (* [filename] is hopefully not "". *)
105 106
  let l = line (start_of_position p) in
  let c1, c2 = characters (start_of_position p) (end_of_position p) in
107 108 109 110 111 112 113
  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 =
114
  (lexeme_start_p lexbuf, lexeme_end_p lexbuf)
115 116 117 118

let with_cpos lexbuf v =
  with_pos (cpos lexbuf) v

POTTIER Francois's avatar
POTTIER Francois committed
119
let string_of_cpos lexbuf =
120 121
  string_of_pos (cpos lexbuf)

POTTIER Francois's avatar
POTTIER Francois committed
122
let joinf f t1 t2 =
123 124 125 126 127
  join (f t1) (f t2)

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

POTTIER Francois's avatar
POTTIER Francois committed
128
let join_located_list ls f =
129 130 131 132 133 134 135 136 137 138 139
  {
    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

140
let one (pos : position) : positions =
141
  [ import (pos, pos) ]
142

143
let lexbuf (lexbuf : lexbuf) : positions =
144
  [ import (lexbuf.lex_start_p, lexbuf.lex_curr_p) ]
145

146
let print (pos : position) =
147 148 149 150 151 152
  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