Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

PPX to have compile time beta reduction #65

Open
wants to merge 1 commit into
base: api-contextual
Choose a base branch
from
Open

PPX to have compile time beta reduction #65

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
57 changes: 56 additions & 1 deletion trace/ppx/trace_ppx.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -102,13 +102,50 @@ let tcall ~loc hd args =
| f::a -> [%expr Obj.repr [%e eapply ~loc f a]] in
[%expr raise (Trace_ppx_runtime.Runtime.TREC_CALL ([%e papp], Obj.repr [%e last]))]

let template_db : (string * expression) list ref = ref []

let template ~loc name args =
if not (List.mem_assoc name !template_db) then
Location.raise_errorf ~loc "template %s not found" name;
let e = List.assoc name !template_db in
let rec aux e = function
| [] -> e
| arg :: args ->
match e with
| [%expr fun [%p? name ] -> [%e? v] ] ->
[%expr let [%p name ] = [%e arg ] in [%e aux v args ]]
| _ -> Location.raise_errorf ~loc "template %s: too many arguments" name
in
aux e args

let enabled = ref false

let has_iftrace_attribute (l : attributes) =
List.exists (fun {attr_name = { txt; _ } ; _ } -> txt = "trace") l

let has_iftrace { ptyp_attributes = l; _ } = has_iftrace_attribute l

let att_elpi_template =
let open Ppxlib.Ast_pattern in
Attribute.(declare "elpi.template" Context.value_binding (pstr nil) ())

let map_template = object
inherit Ast_traverse.map as super

method! structure_item i =
let i = super#structure_item i in
match i.pstr_desc with
| Pstr_value(Nonrecursive, [ { pvb_pat = { ppat_desc = Ppat_var { txt; _ } ; _ }; _ } as vb]) ->
begin match Attribute.get att_elpi_template vb with
| Some () ->
template_db := (txt, vb.pvb_expr) :: !template_db;
let loc = i.pstr_loc in [%stri let () = ()]
| None -> i
end
| _ -> i

end

let map_trace = object(self)
inherit Ast_traverse.map as super

Expand Down Expand Up @@ -311,6 +348,23 @@ let log_extension =

let log_rule = Context_free.Rule.extension log_extension

(* ----------------------------------------------------------------- *)

let template_expand_function ~loc ~path:_ e = match e.pexp_desc with
| Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident name; _}; _ }, args) ->
template ~loc name (List.map snd args)
| _ -> err ~loc "use: [%elpi.template id data..]"

let template_extension =
Extension.declare
"elpi.template"
Extension.Context.expression
Ast_pattern.(single_expr_payload __)
template_expand_function

let template_rule = Context_free.Rule.extension template_extension


(* ----------------------------------------------------------------- *)
(* ----------------------------------------------------------------- *)
(* ----------------------------------------------------------------- *)
Expand All @@ -323,7 +377,8 @@ let arg_trace t =
let () =
Driver.Cookies.add_handler arg_trace;
Driver.register_transformation
~rules:[ log_rule; cur_pred_rule; trace_rule; tcall_rule; spy_rule; spyl_rule; ]
~preprocess_impl:map_template#structure
~rules:[ log_rule; cur_pred_rule; trace_rule; tcall_rule; spy_rule; spyl_rule; template_rule ]
~impl:map_trace#structure
~intf:map_trace#signature
"elpi.trace"