xstrp4_here.ml.310 5.01 KB
Newer Older
gerd's avatar
gerd committed
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 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 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
(* $Id$
 * ----------------------------------------------------------------------
 *
 *)

open Xstrp4_here_types
open Camlp4.PreCast
open Syntax

let camlp4loc (loc1,loc2) =
  Loc.merge
    (Loc.of_lexing_position loc1)
    (Loc.of_lexing_position loc2)
    


let interpolated_expr lexbuf _loc =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   *)
(*
Printf.eprintf "All at line %d bol %d off %d\n%!"
  (Loc.start_line _loc) (Loc.start_bol _loc) (Loc.start_off _loc);
 *)

  let rec parse_here_expr() =
    let tok = Xstrp4_here_lexer.token lexbuf in
      match tok with
	  Textend -> []
	| x       -> x :: parse_here_expr ()
  in

  let rec normalize_literals =
    (* - Concat adjacent literals
     * - Remove empty literals
     *)
    function
	[] -> 
	  []
      | Literal("",_) :: tl -> 
	  normalize_literals tl
      | Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl -> 
	  normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
      | hd :: tl ->
	  hd :: (normalize_literals tl)
  in

  let fix_position p =
    { Lexing.pos_fname = Loc.file_name _loc;
      Lexing.pos_lnum = p.Lexing.pos_lnum + Loc.start_line _loc - 1;
      Lexing.pos_cnum = p.Lexing.pos_cnum + Loc.start_off _loc;
      Lexing.pos_bol  = p.Lexing.pos_bol  + Loc.start_bol _loc;
    }
  in		   

  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
  let _loc = camlp4loc loc in
 *)

  let toklist_ast =
    List.map
      (function
	   Literal(s,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     <:expr< $str:s$ >>	
	 | Variable (sl,fmt,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     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] ->
(*
Printf.eprintf "Var at line %d bol %d off %d\n%!"
  (Loc.start_line _loc) (Loc.start_bol _loc) (Loc.start_off _loc);
 *)
		     <: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@here< [] >>
      | x :: l' ->
	  let ast_l' = mk_list_ast l' in
	  <:expr@here< [ $x$ :: $ast_l'$ ] >>
  in

  let string_mod_ast =    <:expr@here< $uid:"String"$ >> in
  let concat_val_ast =    <:expr@here< $lid:"concat"$ >> in
  let string_concat_ast = <:expr@here< $string_mod_ast$ . $concat_val_ast$ >> in
  let concat_ast =        <:expr@here< $string_concat_ast$ $str:""$ >> in
  let list_ast =          mk_list_ast toklist_ast in
  let result_ast =        <:expr@here< $concat_ast$ $list_ast$ >> in

  match toklist with
      [] ->
	<:expr@here< $str:""$ >>
    | [Literal s] ->
	List.hd toklist_ast   (* = <:expr< $str:s$ >> *)
    | _ ->
	(* General case: *)
	result_ast
;;


let here_expr _loc _loc_name s =
  let lexbuf = Lexing.from_string s in
  interpolated_expr lexbuf _loc
;;

let interpolated_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) filename 
    else
      filename
  in
  let f = open_in pathname in
  let lexbuf = Lexing.from_channel f in
  let _loc =
    Loc.of_tuple
      (pathname, 1, 0, 0, 1, 0, 0, false) in
  interpolated_expr lexbuf _loc
;;


let included_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) 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;
  <:expr< $str:s$ >>
;;


let interpolation = Gram.Entry.mk "interpolation";;

EXTEND Gram
  interpolation:
    [[ s = STRING -> 
	 let lexbuf = Lexing.from_string s in
	 interpolated_expr lexbuf _loc
     ]];

  expr: AFTER "simple"
    [[ "interpolate"; "file"; s = STRING -> interpolated_file s _loc
     | "interpolate"; expr = interpolation -> expr
     | "include_file"; s = STRING -> included_file s _loc
     ]];

END
;;


Quotation.add
  "here"
  Syntax.Quotation.DynAst.expr_tag
  here_expr
;;