xstrp4_here.ml 4.24 KB
Newer Older
gerd's avatar
gerd committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
(* $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)
    

gerd's avatar
gerd committed
16 17 18 19 20 21
class camlp4reloc reloc = 
object 
  inherit Ast.map 

  method loc _ = reloc 
end
gerd's avatar
gerd committed
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

let interpolated_expr lexbuf _loc =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   *)

  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 toklist_ast =
    List.map
      (function
	   Literal(s,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     <:expr< $str:s$ >>	
gerd's avatar
gerd committed
76 77 78 79 80 81 82 83 84 85 86 87
	 | Variable (id,fmt,lexloc) -> 
	     let _loc = camlp4loc lexloc in 
       (* Relocate the ident to the new location *)
       let id = (new camlp4reloc _loc)#ident id in
	     let node =  
        match fmt with
          | "%s" -> 
            <:expr< $id:id$ >>
          | ("%d"|"%i") -> 
            <:expr< Pervasives.string_of_int $id:id$ >>
          | _ ->
            <:expr< Printf.sprintf $str:fmt$ $id:id$ >>
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 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
	     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
150
  let s = Bytes.create n in
gerd's avatar
gerd committed
151 152
  really_input f s 0 n;
  close_in f;
153
  let s = Bytes.to_string s in
gerd's avatar
gerd committed
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
  <: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
;;