xstrp4_here.ml.309 5.59 KB
Newer Older
gerd's avatar
gerd committed
1
(* $Id$
gerd's avatar
gerd committed
2 3 4 5 6 7 8
 * ----------------------------------------------------------------------
 *
 *)

open Xstrp4_here_types
open Pcaml

gerd's avatar
gerd committed
9 10 11 12 13 14
(* Note: Since O'Caml 3.09, the location variable is called "_loc" while
 * in earlier versions it was called "loc". Fortunately, 3.09 allows it
 * to set the name of the variable with the -loc option.
 *)


gerd's avatar
gerd committed
15

gerd's avatar
gerd committed
16 17 18 19 20 21 22 23 24
let interpolated_expr ?(fname="") 
                      ?(lnum_offset=0) ?(cnum_offset=0) ?(bol_offset=0)
		      lexbuf =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   * The locations in this tree are relative to [s]! Before inserting the tree
   * into the surrounding tree an antiquotation node should be created.
   *)

  let rec parse_here_expr() =
gerd's avatar
gerd committed
25 26 27
    let tok = Xstrp4_here_lexer.token lexbuf in
      match tok with
	  Textend -> []
gerd's avatar
gerd committed
28
	| x       -> x :: parse_here_expr ()
gerd's avatar
gerd committed
29 30
  in

31 32 33 34 35 36 37
  let rec normalize_literals =
    (* - Concat adjacent literals
     * - Remove empty literals
     *)
    function
	[] -> 
	  []
gerd's avatar
gerd committed
38
      | Literal("",_) :: tl -> 
39
	  normalize_literals tl
gerd's avatar
gerd committed
40 41
      | Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl -> 
	  normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
42 43 44 45
      | hd :: tl ->
	  hd :: (normalize_literals tl)
  in

gerd's avatar
gerd committed
46 47 48 49 50 51 52 53
  let fix_position p =
    {p with 
       Lexing.pos_fname = fname;
       Lexing.pos_lnum = p.Lexing.pos_lnum + lnum_offset;
       Lexing.pos_cnum = p.Lexing.pos_cnum + cnum_offset + 1;
       Lexing.pos_bol  = p.Lexing.pos_bol  + bol_offset;
    }
  in		   
gerd's avatar
gerd committed
54

gerd's avatar
gerd committed
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
  let fix_positions =
    function
	Literal(s, (p1, p2)) -> 
	  Literal(s, (fix_position p1, fix_position p2))
      | Variable(sl, fmt, (p1, p2)) ->
	  Variable(sl, fmt, (fix_position p1, fix_position p2))
      | other -> 
	  other
  in

  let toklist = 
    List.map fix_positions (normalize_literals (parse_here_expr ())) in
  let loc = 
    let start_pos =
      match toklist with
	  Literal(_,(l1,_)) :: _ -> l1
	| Variable(_,_,(l1,_)) :: _ -> l1
	| _ -> Lexing.dummy_pos
    in
    let end_pos =
      match List.rev toklist with
	  Literal(_,(_,l2)) :: _ -> l2
	| Variable(_,_,(_,l2)) :: _ -> l2
	| _ -> Lexing.dummy_pos
    in
    (start_pos, end_pos)
  in
gerd's avatar
gerd committed
82 83 84 85

  let toklist_ast =
    List.map
      (function
gerd's avatar
gerd committed
86 87
	   Literal(s,loc) -> <:expr< $str:s$ >>
	 | Variable (sl,fmt,loc) -> 
gerd's avatar
gerd committed
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
	     let rec translate_id sl =
	       match sl with
		   s :: ((s' :: _) as sl') -> 
		     let moduleid_ast = <:expr< $uid:s$ >> in
		     let valueid_ast = translate_id sl' in
		     <:expr< $moduleid_ast$ . $valueid_ast$ >>
		 | [s] ->
		     <:expr< $lid:s$ >>
		 | _ ->
		     failwith "Xstrp4.here_expr"
	     in
	     let node =  match fmt with
		 "%s" -> translate_id sl
	       | ("%d"|"%i") -> 
		   let id = translate_id sl in
		   <:expr< $lid:"string_of_int"$ $id$ >>
	       | _ ->
		   let id = translate_id sl in
		   <:expr< ( ( $uid:"Printf"$ . $lid:"sprintf"$ ) 
			     $str:fmt$
			   ) 
		           $id$ >>
	     in
	     node
	 | Textend -> failwith "Xstrp4.here_expr")
      toklist
  in

  let rec mk_list_ast l =
    match l with 
	[] -> <:expr< [] >>
      | x :: l' ->
	  let ast_l' = mk_list_ast l' in
	  <:expr< [ $x$ :: $ast_l'$ ] >>
  in

  let string_mod_ast =    <:expr< $uid:"String"$ >> in
  let concat_val_ast =    <:expr< $lid:"concat"$ >> in
  let string_concat_ast = <:expr< $string_mod_ast$ . $concat_val_ast$ >> in
  let concat_ast =        <:expr< $string_concat_ast$ $str:""$ >> in
  let list_ast =          mk_list_ast toklist_ast in
  let result_ast =        <:expr< $concat_ast$ $list_ast$ >> in
130 131 132 133 134 135 136 137 138

  match toklist with
      [] ->
	<:expr< $str:""$ >>
    | [Literal s] ->
	List.hd toklist_ast   (* = <:expr< $str:s$ >> *)
    | _ ->
	(* General case: *)
	result_ast
gerd's avatar
gerd committed
139 140 141 142
;;


let here_expr s =
gerd's avatar
gerd committed
143 144 145 146 147
  let lexbuf = Lexing.from_string s in
  let result_ast = interpolated_expr ~lnum_offset:(-1) lexbuf in
  let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
  (* <:expr< $anti:result_ast$ >> *)
  result_ast     (* For O'Caml 3.08, this creates better error positions! *)
gerd's avatar
gerd committed
148 149 150 151 152 153 154 155 156 157 158
;;


let interpolated_file filename =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname !input_file) filename 
    else
      filename
  in
  let f = open_in pathname in
gerd's avatar
gerd committed
159 160 161 162 163
  let lexbuf = Lexing.from_channel f in
  let result_ast = interpolated_expr ~fname:pathname lexbuf in
  let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
            (* Will be replaced anyway by camlp4 *)
  <:expr< $anti:result_ast$ >>
gerd's avatar
gerd committed
164 165 166
;;


gerd's avatar
gerd committed
167 168 169 170 171 172 173 174 175 176 177 178
let included_file filename =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname !input_file) filename 
    else
      filename
  in
  let f = open_in pathname in
  let n = in_channel_length f in
  let s = String.create n in
  really_input f s 0 n;
  close_in f;
gerd's avatar
gerd committed
179 180 181 182 183 184 185 186 187
  let start_p = { Lexing.pos_fname = pathname;
		  pos_lnum = 1;
		  pos_bol = 0;
		  pos_cnum = 0 } in
  let end_p = { Lexing.pos_fname = pathname;
		pos_lnum = 1;
		pos_bol = 0;
		pos_cnum = n } in
  let loc = (start_p, end_p) in
gerd's avatar
gerd committed
188 189 190 191
  <:expr< $str:s$ >>
;;


gerd's avatar
gerd committed
192 193 194 195 196
let here_pat s =
  failwith "<<:here< >> documents not allowed in patterns"
;;


gerd's avatar
gerd committed
197 198
let interpolation = Grammar.Entry.create Pcaml.gram "interpolation";;

gerd's avatar
gerd committed
199
EXTEND
gerd's avatar
gerd committed
200 201 202 203 204 205 206 207 208 209 210
  interpolation:
    [[ s = STRING -> 
	 let (start_p,_) = loc in
	 let lexbuf = Lexing.from_string s in
	 interpolated_expr 
	   ~lnum_offset:(start_p.Lexing.pos_lnum - 1)
	   ~cnum_offset:(start_p.Lexing.pos_cnum)
	   ~bol_offset:(start_p.Lexing.pos_bol)
	   lexbuf 
     ]];

gerd's avatar
gerd committed
211 212
  expr: AFTER "simple"
    [[ "interpolate"; "file"; s = STRING -> interpolated_file s
gerd's avatar
gerd committed
213 214
     | "interpolate"; expr = interpolation -> expr
     | "include_file"; s = STRING -> included_file s
gerd's avatar
gerd committed
215
     ]];
gerd's avatar
gerd committed
216

gerd's avatar
gerd committed
217 218 219 220 221 222 223 224 225 226
END
;;


Quotation.add
   "here"
   (Quotation.ExAst(here_expr, here_pat))
;;