diff --git a/mustache/ppx_tyxml_mustache.ml b/mustache/ppx_tyxml_mustache.ml index b53614c3b..fb52d349d 100644 --- a/mustache/ppx_tyxml_mustache.ml +++ b/mustache/ppx_tyxml_mustache.ml @@ -6,14 +6,15 @@ let mustache_from_file file = let chan = open_in file in let lex = Lexing.from_channel chan in Location.init lex file ; - let t = Mustache.parse_lx lex in + let t = Mustache.With_locations.parse_lx lex in close_in chan ; t -let mustache_from_string ~loc string = +let mustache_from_string ~lexloc string = let lex = Lexing.from_string string in - lex.Lexing.lex_curr_p <- loc ; - Mustache.parse_lx lex + lex.Lexing.lex_start_p <- lexloc ; + lex.Lexing.lex_curr_p <- lexloc ; + Mustache.With_locations.parse_lx lex let antiquot_pcdata ~loc ~lang var = let pcdata = Ppx_common.make ~loc lang "pcdata" in @@ -70,7 +71,7 @@ end module Template = struct - type t = desc list + type t = desc Location.loc list and desc = | Markup of string | Pcdata of string @@ -82,17 +83,23 @@ module Template = struct contents: t; } + let mkloc {Mustache.With_locations. loc_start ; loc_end } txt = + let loc = {Location. loc_ghost = true ; loc_start ; loc_end} in + [{Location. loc ; txt}] + let rec of_mustache resolve = - Mustache.fold - ~string:(fun x -> [Markup x]) + Mustache.With_locations.fold + ~string:(fun ~loc x -> mkloc loc @@ Markup x) ~section: - (fun ~inverted name contents -> [Section { inverted ; name ; contents }]) - ~escaped:(fun x -> [Pcdata x]) - ~unescaped:(fun x -> [Expr x]) + (fun ~loc ~inverted name contents -> + mkloc loc @@ Section { inverted ; name ; contents}) + ~escaped:(fun ~loc x -> mkloc loc @@ Pcdata x) + ~unescaped:(fun ~loc x -> mkloc loc @@ Expr x) ~partial: - (fun s -> of_mustache resolve @@ mustache_from_file @@ resolve s) - ~comment:(fun _ -> []) - ~concat:List.concat + (fun ~loc:_ s -> + of_mustache resolve @@ mustache_from_file @@ resolve s) + ~comment:(fun ~loc:_ _ -> []) + ~concat:(fun ~loc:_ l -> List.concat l) let bindings ~env ~sec_env ~id = let f s b b' = match b, b' with @@ -108,9 +115,9 @@ module Template = struct in Exp.let_ Asttypes.Nonrecursive @@ Var.Env.fold make_binding env [] - let rec desc_to_expr ~loc ~lang env t = + let rec desc_to_expr ~lang env {Location. txt; loc} = Ast_helper.default_loc := loc ; - match (t : desc) with + match (txt : desc) with | Markup s -> env, AC.str s | Pcdata s -> Var.add env s Var, antiquot_pcdata ~loc ~lang s @@ -131,7 +138,7 @@ module Template = struct and to_expr ~simplify ~loc ~lang env l = let f (env, acc) t = - let env, expr = desc_to_expr ~loc ~lang env t in + let env, expr = desc_to_expr ~lang env t in env, expr::acc in let env, l = List.fold_left f (env, []) l in @@ -157,9 +164,9 @@ let expr_of_mustache ~loc ~lang t = in Template.make_function env e -let expr_of_string ~loc ~lang s = +let expr_of_string ~loc ~lang ~lexloc s = expr_of_mustache ~loc ~lang @@ - mustache_from_string ~loc:loc.loc_start s + mustache_from_string ~lexloc s (** Mappers *) @@ -169,39 +176,45 @@ open Parsetree let error loc = Ppx_common.error loc "Invalid payload for [%%template]." -let extract_str loc str = match AC.get_str str with +let extract_str loc str = + match AC.get_str_with_quotation_delimiter str with | None -> error loc - | Some s -> s + | Some (s,quot) -> (Ppx_tyxml.Loc.string_start quot loc, s) let expr mapper e = - let loc = e.pexp_loc in + let sloc = e.pexp_loc in match e.pexp_desc with | Pexp_extension ({ txt = ("template" | "tyxml.template")}, payload) -> begin match payload with | PStr [[%stri let [%p? var] = [%e? str] in [%e? e]]] -> - let s = extract_str loc str in - Exp.let_ Asttypes.Nonrecursive - [Vb.mk var @@ expr_of_string ~loc:str.pexp_loc ~lang:Html s] + let loc = str.pexp_loc in + let lexloc, s = extract_str loc str in + Exp.let_ ~loc:sloc Asttypes.Nonrecursive + [Vb.mk ~loc:sloc var @@ + expr_of_string ~loc ~lang:Html ~lexloc s] e | PStr [{pstr_desc = Pstr_eval (str, _)}] -> - let s = extract_str loc str in - expr_of_string ~loc:str.pexp_loc ~lang:Html s + let loc = str.pexp_loc in + let lexloc, s = extract_str loc str in + expr_of_string ~loc ~lang:Html ~lexloc s - | _ -> error loc + | _ -> error sloc end | _ -> Ast_mapper.default_mapper.expr mapper e let structure_item mapper stri = - let loc = stri.pstr_loc in + let sloc = stri.pstr_loc in match stri.pstr_desc with | Pstr_extension (({ txt = ("template" | "tyxml.template")}, payload), _) -> begin match payload with - | PStr [[%stri let [%p? var] = [%e? str]]] -> - let s = extract_str loc str in - Str.value Asttypes.Nonrecursive - [Vb.mk var @@ expr_of_string ~loc:str.pexp_loc ~lang:Html s] - | _ -> error loc + | PStr [([%stri let [%p? var] = [%e? str]] as decl)] -> + let loc = str.pexp_loc in + let lexloc, s = extract_str loc str in + Str.value ~loc:decl.pstr_loc Asttypes.Nonrecursive + [Vb.mk ~loc:decl.pstr_loc var @@ + expr_of_string ~loc ~lang:Html ~lexloc s] + | _ -> error sloc end | _ -> Ast_mapper.default_mapper.structure_item mapper stri diff --git a/ppx/ppx_tyxml.mli b/ppx/ppx_tyxml.mli index 343f71f84..2a537a02d 100644 --- a/ppx/ppx_tyxml.mli +++ b/ppx/ppx_tyxml.mli @@ -33,3 +33,10 @@ val markup_to_expr : contained therein. *) val mapper : string list -> Ast_mapper.mapper + + +(** Utils *) + +module Loc : sig + val string_start : string option -> Location.t -> Lexing.position +end