diff options
Diffstat (limited to 'ppx_metaquot_408.ml')
-rw-r--r-- | ppx_metaquot_408.ml | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/ppx_metaquot_408.ml b/ppx_metaquot_408.ml new file mode 100644 index 0000000..c7ded2a --- /dev/null +++ b/ppx_metaquot_408.ml @@ -0,0 +1,285 @@ +open Migrate_parsetree.Ast_408 + +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* A -ppx rewriter to be used to write Parsetree-generating code + (including other -ppx rewriters) using concrete syntax. + + We support the following extensions in expression position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%stri ...] maps to code which creates the structure item represented by ... + [%sig: ...] maps to code which creates the signature represented by ... + [%sigi: ...] maps to code which creates the signature item represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e ...] where ... is an expression of type Parsetree.expression + [%t ...] where ... is an expression of type Parsetree.core_type + [%p ...] where ... is an expression of type Parsetree.pattern + [%%s ...] where ... is an expression of type Parsetree.structure + or Parsetree.signature depending on the context. + + + All locations generated by the meta quotation are by default set + to [Ast_helper.default_loc]. This can be overriden by providing a custom + expression which will be inserted whereever a location is required + in the generated AST. This expression can be specified globally + (for the current structure) as a structure item attribute: + + ;;[@@metaloc ...] + + or locally for the scope of an expression: + + e [@metaloc ...] + + + + Support is also provided to use concrete syntax in pattern + position. The location and attribute fields are currently ignored + by patterns generated from meta quotations. + + We support the following extensions in pattern position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e? ...] where ... is a pattern of type Parsetree.expression + [%t? ...] where ... is a pattern of type Parsetree.core_type + [%p? ...] where ... is a pattern of type Parsetree.pattern + +*) + +module Main : sig end = struct + open Asttypes + open Parsetree + open Ast_helper + open Ast_convenience_408 + + let prefix ty s = + let open Longident in + match parse ty with + | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s + | _ -> s + + let append ?loc ?attrs e e' = + let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in + Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] + + class exp_builder = + object + method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = constr (prefix ty c) args + method list l = list l + method tuple l = tuple l + method int i = int i + method string s = str s + method char c = char c + method int32 x = Exp.constant (Const.int32 x) + method int64 x = Exp.constant (Const.int64 x) + method nativeint x = Exp.constant (Const.nativeint x) + end + + class pat_builder = + object + method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = pconstr (prefix ty c) args + method list l = plist l + method tuple l = ptuple l + method int i = pint i + method string s = pstr s + method char c = pchar c + method int32 x = Pat.constant (Const.int32 x) + method int64 x = Pat.constant (Const.int64 x) + method nativeint x = Pat.constant (Const.nativeint x) + end + + + let get_exp loc = function + | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e + | _ -> + Format.eprintf "%aError: Expression expected@." + Location.print_loc loc; + exit 2 + + let get_typ loc = function + | PTyp t -> t + | _ -> + Format.eprintf "%aError: Type expected@." + Location.print_loc loc; + exit 2 + + let get_pat loc = function + | PPat (t, None) -> t + | _ -> + Format.eprintf "%aError: Pattern expected@." + Location.print_loc loc; + exit 2 + + let exp_lifter loc map = + let map = map.Ast_mapper.expr map in + object + inherit [_] Ast_lifter_408.lifter as super + inherit exp_builder + + (* Special support for location in the generated AST *) + method! lift_Location_t _ = loc + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_structure str = + List.fold_right + (function + | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_structure_item x)) + str (nil ()) + + method! lift_Parsetree_signature sign = + List.fold_right + (function + | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_signature_item x)) + sign (nil ()) + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_core_type x + end + + let pat_lifter map = + let map = map.Ast_mapper.pat map in + object + inherit [_] Ast_lifter_408.lifter as super + inherit pat_builder + + (* Special support for location and attributes in the generated AST *) + method! lift_Location_t _ = Pat.any () + method! lift_Parsetree_attributes _ = Pat.any () + method! lift_loc_stack _ = Pat.any () + + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_core_type x + end + + let loc = ref (Exp.field (evar "Ast_helper.default_loc") (lid "contents")) + + let handle_attr = function + | { attr_name = {txt="metaloc";loc=l} + ; attr_payload = e + ; attr_loc = _ } -> loc := get_exp l e + | _ -> () + + let with_loc ?(attrs = []) f = + let old_loc = !loc in + List.iter handle_attr attrs; + let r = f () in + loc := old_loc; + r + + let expander _config _cookies = + let open Ast_mapper in + let super = default_mapper in + let expr this e = + with_loc ~attrs:e.pexp_attributes + (fun () -> + match e.pexp_desc with + | Pexp_extension({txt="expr";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) + | Pexp_extension({txt="pat";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) + | Pexp_extension({txt="str";_}, PStr e) -> + (exp_lifter !loc this) # lift_Parsetree_structure e + | Pexp_extension({txt="stri";_}, PStr [e]) -> + (exp_lifter !loc this) # lift_Parsetree_structure_item e + | Pexp_extension({txt="sig";_}, PSig e) -> + (exp_lifter !loc this) # lift_Parsetree_signature e + | Pexp_extension({txt="sigi";_}, PSig [e]) -> + (exp_lifter !loc this) # lift_Parsetree_signature_item e + | Pexp_extension({txt="type";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.expr this e + ) + and pat this p = + with_loc ~attrs:p.ppat_attributes + (fun () -> + match p.ppat_desc with + | Ppat_extension({txt="expr";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_expression (get_exp l e) + | Ppat_extension({txt="pat";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) + | Ppat_extension({txt="str";_}, PStr e) -> + (pat_lifter this) # lift_Parsetree_structure e + | Ppat_extension({txt="stri";_}, PStr [e]) -> + (pat_lifter this) # lift_Parsetree_structure_item e + | Ppat_extension({txt="sig";_}, PSig e) -> + (pat_lifter this) # lift_Parsetree_signature e + | Ppat_extension({txt="sigi";_}, PSig [e]) -> + (pat_lifter this) # lift_Parsetree_signature_item e + | Ppat_extension({txt="type";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.pat this p + ) + and structure this l = + with_loc + (fun () -> super.structure this l) + + and structure_item this x = + begin match x.pstr_desc with + | Pstr_attribute x -> handle_attr x + | _ -> () + end; + super.structure_item this x + + and signature this l = + with_loc + (fun () -> super.signature this l) + + and signature_item this x = + begin match x.psig_desc with + | Psig_attribute x -> handle_attr x + | _ -> () + end; + super.signature_item this x + + in + {super with expr; pat; structure; structure_item; signature; signature_item} + + let () = + let open Migrate_parsetree in + Driver.register ~name:"metaquot_408" Versions.ocaml_408 expander +end |