From c79966c913efd5f1d7e2ee87f52b399dfc87aa4e Mon Sep 17 00:00:00 2001 From: Josh Allmann Date: Wed, 2 Mar 2016 15:04:00 -0800 Subject: [PATCH 1/4] Update oasis with ppx_core dependency. The '-predicates' flag is necessary due to the issue here: https://github.com/janestreet/ppx_core/issues/1 While the recommended fix is to edit the local _tags file, that introduces a hard dependency on OCaml >= 4.02 due to some changes in the ocamlbuild _tags syntax. To maintain compatibility with older OCaml versions, specify the -predicates build flag as done here. --- _oasis | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/_oasis b/_oasis index 5dcf0cc..8e5fe33 100644 --- a/_oasis +++ b/_oasis @@ -62,9 +62,11 @@ Library "ppx" Executable "ppx_sqlexpr" Path: src/ppx/ MainIs: ppx_sqlexpr.ml - BuildDepends: unix, re.pcre, compiler-libs.common, ppx_tools.metaquot + BuildDepends: unix, re.pcre, compiler-libs.common, ppx_tools.metaquot, ppx_core, ppx_driver CompiledObject: best Install: true + ByteOpt: -predicates ppx_driver + NativeOpt: -predicates ppx_driver Executable "example" Path: tests/ From 892b7d91dc39d9278f1b47d33104d072b632f46e Mon Sep 17 00:00:00 2001 From: Josh Allmann Date: Wed, 2 Mar 2016 15:10:21 -0800 Subject: [PATCH 2/4] Re-run oasis setup. --- _tags | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/_tags b/_tags index bbe3b4e..d5f16a7 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 8c33eb34542ae662c8d9b52b2978ec0d) +# DO NOT EDIT (digest: f5905681661b090fb1b90f7dc5c9e678) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -32,11 +32,19 @@ true: annot, bin_annot # Library ppx "src/ppx/ppx.cmxs": use_ppx # Executable ppx_sqlexpr +: oasis_executable_ppx_sqlexpr_byte +: oasis_executable_ppx_sqlexpr_byte +: oasis_executable_ppx_sqlexpr_native +: oasis_executable_ppx_sqlexpr_native : pkg_compiler-libs.common +: pkg_ppx_core +: pkg_ppx_driver : pkg_ppx_tools.metaquot : pkg_re.pcre : pkg_unix : pkg_compiler-libs.common +: pkg_ppx_core +: pkg_ppx_driver : pkg_ppx_tools.metaquot : pkg_re.pcre : pkg_unix From 580f5d55ba20f488d09eacc2156fe4786c4e1472 Mon Sep 17 00:00:00 2001 From: Josh Allmann Date: Wed, 2 Mar 2016 20:41:01 -0800 Subject: [PATCH 3/4] Add ppx_{core,driver} to opam file. --- opam | 2 ++ 1 file changed, 2 insertions(+) diff --git a/opam b/opam index 77d40f9..8086438 100644 --- a/opam +++ b/opam @@ -14,6 +14,8 @@ build-doc: [["ocaml" "setup.ml" "-doc"]] remove: [["ocamlfind" "remove" "sqlexpr"]] depends: [ "ppx_tools" + "ppx_core" + "ppx_driver" "estring" "csv" "lwt" {>= "2.2.0"} From 2fe478214c81b6adab9346c97502abec318b637a Mon Sep 17 00:00:00 2001 From: Josh Allmann Date: Mon, 29 Feb 2016 19:32:32 -0800 Subject: [PATCH 4/4] Hoist cached SQL to the top of each structure item binding. --- src/ppx/ppx_sqlexpr.ml | 53 +++++++++++++++++++++++++++++++++++++++--- 1 file changed, 50 insertions(+), 3 deletions(-) diff --git a/src/ppx/ppx_sqlexpr.ml b/src/ppx/ppx_sqlexpr.ml index 88e999d..1bbeeeb 100644 --- a/src/ppx/ppx_sqlexpr.ml +++ b/src/ppx/ppx_sqlexpr.ml @@ -125,21 +125,68 @@ let call_sqlcheck loc = function | _ -> raise (Location.Error(Location.error ~loc ( "sqlcheck extension accepts \"sqlite\""))) +let shared_exprs = Hashtbl.create 25 + +let shared_expr_id = function + | Pexp_ident {txt} -> + let id = Longident.last txt in + if Hashtbl.mem shared_exprs id then Some id else None + | _ -> None + +let register_shared_expr = + let n = ref 0 in + fun expr -> + let id = "__ppx_sqlexpr_shared_" ^ string_of_int !n in + incr n; + Hashtbl.add shared_exprs id expr; + id + +let get_shared_expr = Hashtbl.find shared_exprs + +let shared_exprs = object + inherit [string list] Ppx_core.Ast_traverse.fold as super + + method! expression e acc = + let acc = super#expression e acc in + match shared_expr_id e.pexp_desc with + | Some id -> id::acc + | None -> acc +end + +let map_expr mapper loc expr = + let expr = mapper.Ast_mapper.expr mapper expr in + let ids = shared_exprs#expression expr [] in + with_default_loc loc (fun () -> + List.fold_left (fun acc id -> + [%expr let [%p AC.pvar id] = [%e get_shared_expr id] in [%e acc]]) + expr ids) + let new_mapper argv = Ast_mapper.({ default_mapper with - expr = fun mapper expr -> + expr = (fun mapper expr -> match expr with (* is this an extension node? *) | {pexp_desc = Pexp_extension ({txt = "sql"; loc}, pstr)} -> call gen_sql loc pstr | {pexp_desc = Pexp_extension ({txt = "sqlc"; loc}, pstr)} -> - call (gen_sql ~cacheable:true) loc pstr + let expr = call (gen_sql ~cacheable:true) loc pstr in + let id = register_shared_expr expr in + Exp.ident ~loc {txt=Longident.Lident id; loc} | {pexp_desc = Pexp_extension ({txt = "sqlinit"; loc}, pstr)} -> call (gen_sql ~init:true) loc pstr | {pexp_desc = Pexp_extension ({txt = "sqlcheck"; loc}, pstr)} -> call_sqlcheck loc pstr (* Delegate to the default mapper *) - | x -> default_mapper.expr mapper x; + | x -> default_mapper.expr mapper x); + structure_item = (fun mapper structure_item -> + match structure_item with + | {pstr_desc = Pstr_value (rec_flag, value_bindings); pstr_loc} -> + (* since structure_item gets mapped before expr, need to preemptively + * apply our expr mapping to the value_bindings to resolve extensions *) + let es = List.map (fun x -> map_expr mapper pstr_loc x.pvb_expr) value_bindings in + let vbs = List.map2 (fun x y -> {x with pvb_expr = y}) value_bindings es in + { structure_item with pstr_desc = Pstr_value (rec_flag, vbs)} + | x -> default_mapper.structure_item mapper x); }) let () =