add support for wrapped objects

README.md

@@ -96,6 +96,25 @@ List.iter
   res
 ```
 
+## Wrapped objects
+
+```ocaml
+let%lwt res =
+  [%pgsql.wrappedobject
+    dbh
+    "SELECT employees.*,owners.* FROM employees LEFT JOIN owners ON employees.name = owners.name"
+  ]
+in
+List.iter
+  (fun row ->
+    Printf.printf
+      "%s has %d shares and is paid %f.\n"
+      row#employees#name
+      (Int32.to_int row#owners#shares)
+      row#employees#salary)
+  rows
+```
+
 The PPX now also supports `${...}` expansions.
 
 ```ocaml

_oasis

@@ -113,3 +113,7 @@ Test "pgocaml_highlevel"
 Test "test_re"
   Command:              $test_re
   WorkingDirectory:     tests
+
+Test "test_ppx"
+ Command: $test_ppx
+ WorkingDirectory: tests_ppx 

ppx/ppx_pgsql.ml

@@ -247,7 +247,7 @@ let mk_listpat ~loc results =
     (range 0 (List.length results))
     ([%pat? []][@metaloc loc])
 
-let pgsql_expand ~genobject ?(flags = []) loc dbh query =
+let pgsql_expand ~genobject ~wrapobject ?(flags = []) loc dbh query =
   let open Rresult in
   let (key, f_execute, f_nullable_results, comment_src_loc) = parse_flags flags loc in
   let query =
@@ -502,33 +502,149 @@ let pgsql_expand ~genobject ?(flags = []) loc dbh query =
   match (genobject, results') with
   | true, Some results ->
     let list = mk_listpat ~loc results in
-    let fields =
-      List.map
-        (fun ({PGOCaml.name; field_type; _}, nullable) ->
-          name, coretype_of_type ~loc field_type, nullable)
-        results
-    in
     let convert =
-      List.map2
-        (fun (name, _, _) conv ->
-          { pcf_desc = Pcf_method(
-                {txt = name; loc}
-              , Public
-              , Cfk_concrete(Fresh, conv)
-            )
-          ; pcf_loc = loc
-          ; pcf_attributes = []
-          }
-        )
-        fields
-        (mk_conversions ~loc ~dbh:my_dbh results)
-      |> fun fields ->
-          Exp.mk (
-            Pexp_object({
-              pcstr_self = Pat.any ~loc ()
-            ; pcstr_fields = fields
-            })
+      let fields =
+        List.map
+          (fun ({PGOCaml.name; table; _}, _) ->
+            name, table
           )
+          results
+      in
+      (* we need a list of methods for the object *)
+      let kids =
+        if wrapobject
+        then begin
+          let module SMap = Map.Make(String) in
+          let query = "SELECT relname,oid FROM pg_class" in
+          let query_nam = "tables_oids_pgsql" in
+          let () = PGOCaml.prepare my_dbh ~name:query_nam ~query () in
+          let rows = PGOCaml.execute my_dbh ~name:query_nam ~params:[] () in
+          let module OIDsMap = Map.Make(struct
+            type t = int32
+            let compare = compare
+          end)
+          in
+          (* need to be able to get the name of a table from an OID *)
+          let oidsmap =
+            List.fold_left
+              (fun map [Some nam; Some oid] ->
+                OIDsMap.add (Int32.of_string oid) nam map)
+              OIDsMap.empty
+              rows
+          in
+          let descs =
+            List.map2
+              (fun (name, table) conv -> (name, table), conv)
+              fields
+              (mk_conversions ~loc ~dbh:my_dbh results)
+          in
+          let module FieldSet = Set.Make(struct
+            type t = (string * expression)
+            (* I've heard that the generic [compare] function is bad, but I'm
+               not about to write a comparator for [expression]s *)
+            let compare (a:t) (b:t) = compare a b
+          end)
+          in
+          let module StringMap = Map.Make(struct
+            type t = string option
+            let compare = compare
+          end) in
+          (* we need to collect the columns into tables *)
+          let collected =
+            List.fold_left
+              (fun acc ((label, oid), conv) ->
+                let tnam =
+                  match oid with
+                    | None -> None
+                    | Some oid -> Some(OIDsMap.find oid oidsmap)
+                in
+                let new_val =
+                  match StringMap.find_opt tnam acc with
+                    | Some fs -> FieldSet.add (label, conv) fs
+                    | None -> FieldSet.singleton (label, conv)
+                in
+                (* make sure that there's only one definition of any given set *)
+                StringMap.remove tnam acc
+                |> StringMap.add tnam new_val
+              )
+              StringMap.empty
+              descs
+          in
+          let sub_methods =
+            StringMap.bindings collected
+            |> List.map
+                  (fun (tnam, fields) ->
+                    let fields = FieldSet.elements fields in
+                    match tnam with
+                      | Some nam ->
+                        (* make a sub-object *)
+                        let methods =
+                          List.map
+                            (fun (name, conv) ->
+                              { pcf_desc = Pcf_method(
+                                    {txt = name; loc}
+                                  , Public
+                                  , Cfk_concrete(Fresh, conv)
+                                )
+                              ; pcf_loc = loc
+                              ; pcf_attributes = []
+                              })
+                            fields
+                        in
+                        let sub_object = Exp.mk (
+                            Pexp_object({
+                              pcstr_self = Pat.any ~loc ()
+                            ; pcstr_fields = methods
+                            })
+                          )
+                        in
+                        [ { pcf_desc = Pcf_method(
+                                {txt = nam; loc}
+                              , Public
+                              , Cfk_concrete(Fresh, sub_object)
+                            )
+                          ; pcf_loc = loc
+                          ; pcf_attributes = []
+                          }
+                        ]
+                      | None ->
+                        (* all the fields that aren't associated with a table *)
+                        List.map
+                          (fun (name, conv) ->
+                            { pcf_desc = Pcf_method(
+                                  {txt = name; loc}
+                                , Public
+                                , Cfk_concrete(Fresh, conv)
+                              )
+                            ; pcf_loc = loc
+                            ; pcf_attributes = []
+                            })
+                          fields
+                  )
+          in
+          List.flatten sub_methods
+        end
+        else
+          List.map2
+            (fun (name, _table) conv ->
+              { pcf_desc = Pcf_method(
+                    {txt = name; loc}
+                  , Public
+                  , Cfk_concrete(Fresh, conv)
+                )
+              ; pcf_loc = loc
+              ; pcf_attributes = []
+              }
+            )
+            fields
+            (mk_conversions ~loc ~dbh:my_dbh results)
+      in
+      Exp.mk (
+        Pexp_object({
+          pcstr_self = Pat.any ~loc ()
+        ; pcstr_fields = kids
+        })
+      )
     in
     let expr = mkexpr ~convert ~list in
     Ok expr
@@ -548,12 +664,12 @@ let pgsql_expand ~genobject ?(flags = []) loc dbh query =
   | false, None ->
     Ok ([%expr PGOCaml.bind [%e expr] (fun _rows -> PGOCaml.return ())][@metaloc loc])
 
-let expand_sql ~genobject loc dbh extras =
+let expand_sql ~genobject ~wrapobject loc dbh extras =
      let query, flags =
        match List.rev extras with
        | [] -> assert false
        | query :: flags -> query, flags in
-     try pgsql_expand ~genobject ~flags loc dbh query
+     try pgsql_expand ~genobject ~wrapobject ~flags loc dbh query
      with
      | Failure s -> Error(s, loc)
      | PGOCaml.Error s -> Error(s, loc)
@@ -602,11 +718,12 @@ let pgocaml_mapper _argv =
         ; _
         } when String.starts_with txt "pgsql" ->
         let open Rresult in
-        let genobject = txt = "pgsql.object" in
+        let genobject = txt = "pgsql.object" || txt = "pgsql.wrappedobject" in
+        let wrapobject = txt = "pgsql.wrappedobject" in
         ( match list_of_string_args (default_mapper.expr mapper) args with
           | [] -> unsupported loc
           | args ->
-            let x = expand_sql ~genobject loc dbh args in
+            let x = expand_sql ~genobject ~wrapobject loc dbh args in
             ( match x with
               | Rresult.Ok ({ pexp_desc; pexp_loc = _ ; pexp_attributes }) ->
                 {pexp_desc; pexp_loc = qloc; pexp_attributes}

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.3.0~rc6 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 2f365a540a349a0ef99589edfeafa536) *)
+(* DO NOT EDIT (digest: f810fb967fca698e19b6f75d7971f69e) *)
 (*
    Regenerated by OASIS v0.4.11
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -7014,6 +7014,14 @@ let setup_t =
                    [(OASISExpr.EBool true, ("$test_re", []))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
+              });
+          ("test_ppx",
+            CustomPlugin.Test.main
+              {
+                 CustomPlugin.cmd_main =
+                   [(OASISExpr.EBool true, ("$test_ppx", []))];
+                 cmd_clean = [(OASISExpr.EBool true, None)];
+                 cmd_distclean = [(OASISExpr.EBool true, None)]
               })
        ];
      doc =
@@ -7054,6 +7062,14 @@ let setup_t =
                    [(OASISExpr.EBool true, ("$test_re", []))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
+              });
+          ("test_ppx",
+            CustomPlugin.Test.clean
+              {
+                 CustomPlugin.cmd_main =
+                   [(OASISExpr.EBool true, ("$test_ppx", []))];
+                 cmd_clean = [(OASISExpr.EBool true, None)];
+                 cmd_distclean = [(OASISExpr.EBool true, None)]
               })
        ];
      clean_doc =
@@ -7092,6 +7108,14 @@ let setup_t =
                    [(OASISExpr.EBool true, ("$test_re", []))];
                  cmd_clean = [(OASISExpr.EBool true, None)];
                  cmd_distclean = [(OASISExpr.EBool true, None)]
+              });
+          ("test_ppx",
+            CustomPlugin.Test.distclean
+              {
+                 CustomPlugin.cmd_main =
+                   [(OASISExpr.EBool true, ("$test_ppx", []))];
+                 cmd_clean = [(OASISExpr.EBool true, None)];
+                 cmd_distclean = [(OASISExpr.EBool true, None)]
               })
        ];
      distclean_doc = [];
@@ -8589,6 +8613,30 @@ let setup_t =
                         ];
                       test_tools =
                         [ExternalTool "ocamlbuild"; ExternalTool "make"]
+                   });
+               Test
+                 ({
+                     cs_name = "test_ppx";
+                     cs_data = PropList.Data.create ();
+                     cs_plugin_data = []
+                  },
+                   {
+                      test_type = (`Test, "custom", Some "0.4");
+                      test_command =
+                        [(OASISExpr.EBool true, ("$test_ppx", []))];
+                      test_custom =
+                        {
+                           pre_command = [(OASISExpr.EBool true, None)];
+                           post_command = [(OASISExpr.EBool true, None)]
+                        };
+                      test_working_directory = Some "tests_ppx";
+                      test_run =
+                        [
+                           (OASISExpr.ENot (OASISExpr.EFlag "tests"), false);
+                           (OASISExpr.EFlag "tests", true)
+                        ];
+                      test_tools =
+                        [ExternalTool "ocamlbuild"; ExternalTool "make"]
                    })
             ];
           disable_oasis_section = [];
@@ -8633,15 +8681,15 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.11";
-     oasis_digest = Some "G\147\248;Y\215\150\149\023\149<\219G6u\206";
+     oasis_digest = Some "K\244\127\197\163p+\148\238\237\137I\214\191\200>";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 8645 "setup.ml"
+# 8693 "setup.ml"
 let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t
 open BaseCompat.Compat_0_4
 (* OASIS_STOP *)

src/META

@@ -1,8 +1,8 @@
 # OASIS_START
-# DO NOT EDIT (digest: e58a34179142942b0e3834bda9a70ebb)
+# DO NOT EDIT (digest: 87bd2ac2205032a2709c35db80f4e081)
 version = "3.1"
 description = "OCaml bindings for the PostgreSQL database"
-requires = "unix calendar csv re bytes hex rresult"
+requires = "unix calendar csv re bytes hex"
 archive(byte) = "pgocaml.cma"
 archive(byte, plugin) = "pgocaml.cma"
 archive(native) = "pgocaml.cmxa"