wrapper/position.ml

   1 open Lexing
   2
   3 type t =
   4     {
   5       start_p : Lexing.position;
   6       end_p   : Lexing.position
   7     }
   8
   9 type position = t
  10
  11 type 'a located =
  12     {
  13       value    : 'a;
  14       position : t;
  15     }
  16
  17 let value { value = v } =
  18   v
  19
  20 let position { position = p } =
  21   p
  22
  23 let destruct p =
  24   (p.value, p.position)
  25
  26 let with_pos p v =
  27   {
  28     value     = v;
  29     position  = p;
  30   }
  31
  32 let with_poss p1 p2 v =
  33   with_pos { start_p = p1; end_p = p2 } v
  34
  35 let map f v =
  36   {
  37     value     = f v.value;
  38     position  = v.position;
  39   }
  40
  41 let iter f { value = v } =
  42   f v
  43
  44 let mapd f v =
  45   let w1, w2 = f v.value in
  46   let pos = v.position in
  47     ({ value = w1; position = pos }, { value = w2; position = pos })
  48
  49 let dummy =
  50   {
  51     start_p = Lexing.dummy_pos;
  52     end_p   = Lexing.dummy_pos
  53   }
  54
  55 let unknown_pos v =
  56   {
  57     value     = v;
  58     position  = dummy
  59   }
  60
  61 let start_of_position p = p.start_p
  62
  63 let end_of_position p = p.end_p
  64
  65 let filename_of_position p =
  66   p.start_p.Lexing.pos_fname
  67
  68 let line p =
  69   p.pos_lnum
  70
  71 let column p =
  72   p.pos_cnum - p.pos_bol
  73
  74 let characters p1 p2 =
  75   (column p1, p2.pos_cnum - p1.pos_bol) (* intentionally [p1.pos_bol] *)
  76
  77 let join x1 x2 =
  78   {
  79     start_p = if x1 = dummy then x2.start_p else x1.start_p;
  80     end_p   = if x2 = dummy then x1.end_p else x2.end_p
  81   }
  82
  83 let lex_join x1 x2 =
  84   {
  85     start_p = x1;
  86     end_p   = x2
  87   }
  88
  89 let join_located l1 l2 f =
  90   {
  91     value    = f l1.value l2.value;
  92     position = join l1.position l2.position;
  93   }
  94
  95 let string_of_lex_pos p =
  96   let c = p.pos_cnum - p.pos_bol in
  97   (string_of_int p.pos_lnum)^":"^(string_of_int c)
  98
  99 let string_of_pos p =
 100   let filename = filename_of_position p in
 101   let l = line p.start_p in
 102   let c1, c2 = characters p.start_p p.end_p in
 103     if filename = "" then
 104       Printf.sprintf "Line %d, characters %d-%d" l c1 c2
 105     else
 106       Printf.sprintf "File \"%s\", line %d, characters %d-%d" filename l c1 c2
 107
 108 let pos_or_undef = function
 109   | None -> dummy
 110   | Some x -> x
 111
 112 let cpos lexbuf =
 113   {
 114     start_p = Lexing.lexeme_start_p lexbuf;
 115     end_p   = Lexing.lexeme_end_p   lexbuf;
 116   }
 117
 118 let with_cpos lexbuf v =
 119   with_pos (cpos lexbuf) v
 120
 121 let string_of_cpos lexbuf =
 122   string_of_pos (cpos lexbuf)
 123
 124 let joinf f t1 t2 =
 125   join (f t1) (f t2)
 126
 127 let ljoinf f =
 128   List.fold_left (fun p t -> join p (f t)) dummy
 129
 130 let join_located_list ls f =
 131   {
 132     value     = f (List.map (fun l -> l.value) ls);
 133     position  = ljoinf (fun x -> x.position) ls
 134   }