(* $Id: xstrp4_here.ml 35 2010-11-30 14:34:06Z gerd $ * ---------------------------------------------------------------------- * *) 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) class camlp4reloc reloc = object inherit Ast.map method loc _ = reloc end 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$ >> | 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$ >> 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 ;;