WIP: hoisting

_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/

_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
+<src/ppx/ppx_sqlexpr.{native,byte}>: oasis_executable_ppx_sqlexpr_byte
+<src/ppx/*.ml{,i,y}>: oasis_executable_ppx_sqlexpr_byte
+<src/ppx/ppx_sqlexpr.{native,byte}>: oasis_executable_ppx_sqlexpr_native
+<src/ppx/*.ml{,i,y}>: oasis_executable_ppx_sqlexpr_native
 <src/ppx/ppx_sqlexpr.{native,byte}>: pkg_compiler-libs.common
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_ppx_core
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_ppx_driver
 <src/ppx/ppx_sqlexpr.{native,byte}>: pkg_ppx_tools.metaquot
 <src/ppx/ppx_sqlexpr.{native,byte}>: pkg_re.pcre
 <src/ppx/ppx_sqlexpr.{native,byte}>: pkg_unix
 <src/ppx/*.ml{,i,y}>: pkg_compiler-libs.common
+<src/ppx/*.ml{,i,y}>: pkg_ppx_core
+<src/ppx/*.ml{,i,y}>: pkg_ppx_driver
 <src/ppx/*.ml{,i,y}>: pkg_ppx_tools.metaquot
 <src/ppx/*.ml{,i,y}>: pkg_re.pcre
 <src/ppx/*.ml{,i,y}>: pkg_unix

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"}

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 () =