Add a -tracing flag that generates debugging/tracing calls

impl/ocaml/sqlgg_traits.ml

@@ -126,3 +126,31 @@ module type M_io = sig
   val execute : [>`WR] connection -> string -> (statement -> result IO.future) -> int64 IO.future
 
 end
+
+module type M_tracing = sig
+
+  include M
+
+  val tracing_span :
+    ?operation:string ->
+    ?tables:string list ->
+    statement:string ->
+    string (* span-name *) ->
+    (unit -> 'r) ->
+    'r
+
+end
+
+module type M_tracing_io = sig
+
+  include M_io
+
+  val tracing_span :
+    ?operation:string ->
+    ?tables:string list ->
+    statement:string ->
+    string (* span-name *) ->
+    (unit -> 'r IO.future) ->
+    'r IO.future
+
+end

lib/stmt.ml

@@ -20,10 +20,36 @@ type kind = | Select of cardinality
             | Delete of Sql.table_name list
             | Alter of Sql.table_name list
             | Drop of Sql.table_name
-            | CreateRoutine of string
+            | CreateRoutine of string * Sql.Type.t option
             | Other
             [@@deriving show {with_path=false}]
 
+let kind_to_operation_name = function
+| Select _ -> Some "SELECT"
+| Insert _ -> Some "INSERT"
+| Create _ -> Some "CREATE TABLE"
+| CreateIndex _ -> Some "CREATE INDEX"
+| Update _ -> Some "UPDATE"
+| Delete _ -> Some "DELETE"
+| Alter _ -> Some "ALTER TABLE"
+| Drop _ -> Some "DROP TABLE"
+| CreateRoutine (_, Some _) -> Some "CREATE FUNCTION"
+| CreateRoutine (_, None) -> Some "CREATE PROCEDURE"
+| Other -> None
+
+let kind_to_table_names = function
+| Create t -> [t]
+| CreateIndex _ -> [] (* FIXME *)
+| Update (Some t) -> [t]
+| Update None -> []
+| Insert (_,t) -> [t]
+| Delete ts -> ts
+| Alter ts -> ts
+| Drop t -> [t]
+| Select _  ->  [] (* FIXME *)
+| CreateRoutine (_s, _ret) -> []
+| Other -> []
+
 type category = DDL | DQL | DML | DCL | TCL | OTHER [@@deriving show {with_path=false}, enum]
 
 let all_categories = List.init (max_category - min_category) (fun i -> Option.get @@ category_of_enum @@ min_category + i)

lib/syntax.ml

@@ -508,8 +508,8 @@ let eval (stmt:Sql.stmt) =
     let params = update_tables sources ss w in
     [], params, Update None
   | Select select -> eval_select_full empty_env select
-  | CreateRoutine (name,_,_) ->
-    [], [], CreateRoutine name
+  | CreateRoutine (name,ret,_) ->
+    [], [], CreateRoutine (name, ret)
 
 (* FIXME unify each choice separately *)
 let unify_params l =

src/cli.ml

@@ -95,6 +95,7 @@ let main () =
     "-gen", Arg.String set_out, "cxx|caml|java|xml|csharp|none Set output language (default: none)";
     "-name", Arg.String (fun x -> name := x), "<identifier> Set output module name (default: sqlgg)";
     "-params", Arg.String set_params_mode, "named|unnamed|oracle|postgresql|none Output query parameters substitution (default: none)";
+    "-tracing", Arg.Unit (fun () -> Sqlgg_config.tracing := true), "invoke a tracing callback on every query (default: false)";
     "-debug", Arg.Int Sqlgg_config.set_debug_level, "<N> set debug level";
     "-no-header", Arg.Unit (fun () -> Sqlgg_config.gen_header := None),
       "do not put version header in generated output";

src/gen.ml

@@ -63,7 +63,7 @@ let choose_name props kind index =
   | Alter t -> sprintf "alter_%s_%u" (String.concat "_" @@ List.map fix t) index
   | Drop t -> sprintf "drop_%s" (fix t)
   | Select _  -> sprintf "select_%u" index
-  | CreateRoutine s -> sprintf "create_routine_%s" (fix' s)
+  | CreateRoutine (s, _ret) -> sprintf "create_routine_%s" (fix' s)
   | Other -> sprintf "statement_%u" index
   in
   make_name props name

src/gen_caml.ml

@@ -105,6 +105,10 @@ let inline_values = String.concat " "
 let quote = String.replace_chars (function '\n' -> "\\n\\\n" | '\r' -> "" | '"' -> "\\\"" | c -> String.make 1 c)
 let quote s = "\"" ^ quote s ^ "\""
 
+let quote_list ss =
+  let body = List.map quote ss |> String.concat "; " in
+  "[" ^ body ^ "]"
+
 let rec replace_all ~str ~sub ~by =
   match String.replace ~str ~sub ~by with
   | (true,s) -> replace_all ~str:s ~sub ~by
@@ -389,6 +393,17 @@ let make_sql l =
   Buffer.add_string b ")";
   Buffer.contents b
 
+let output_tracing ~op ~tables ~sql_var name =
+  match op, tables with
+  | Some op, [] ->
+    output "T.tracing_span ~operation:%s ~statement:%s %s @@ fun () ->" (quote op) sql_var (quote name)
+  | None, [] ->
+    output "T.tracing_span ~statement:%s %s @@ fun () ->" sql_var (quote name)
+  | Some op, _::_ ->
+    output "T.tracing_span ~operation:%s ~tables:%s ~statement:%s %s @@ fun () ->" (quote op) (quote_list tables) sql_var (quote name)
+  | None, _::_ ->
+    failwith "UNREACHABLE"
+
 let generate_stmt style index stmt =
   let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in
   let subst = Props.get_all stmt.props "subst" in
@@ -400,8 +415,10 @@ let generate_stmt style index stmt =
   output "let %s db %s =" name all_inputs;
   inc_indent ();
   let sql = make_sql @@ get_sql stmt in
-  let sql = match subst with
-  | [] -> sql
+  begin match subst with
+  | [] ->
+    output "let __sqlgg_sql = %s" sql;
+    output "in"
   | vars ->
     output "let __sqlgg_sql =";
     output "  let replace_all ~str ~sub ~by =";
@@ -413,9 +430,8 @@ let generate_stmt style index stmt =
     output "  let sql = %s in" sql;
     List.iter (fun var -> output "  let sql = replace_all ~str:sql ~sub:(\"%%%%%s%%%%\") ~by:%s in" var var) vars;
     output "  sql";
-    output "in";
-    "__sqlgg_sql"
-  in
+    output "in"
+  end;
   let (func,callback) = output_schema_binder index stmt.schema stmt.kind in
   let params_binder_name = output_params_binder index stmt.vars in
   if style = `Fold then output "let r_acc = ref acc in";
@@ -426,7 +442,12 @@ let generate_stmt style index stmt =
     | `List -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x :: !r_acc))" callback
     | `Direct -> "", callback (* or empty string *)
   in
-  let exec = sprintf "T.%s db %s %s %s" func sql params_binder_name callback in
+  if !Sqlgg_config.tracing then begin
+    let op = Stmt.kind_to_operation_name stmt.kind in
+    let tables = List.map Sql.show_table_name (Stmt.kind_to_table_names stmt.kind) in
+    output_tracing ~op ~tables ~sql_var:"__sqlgg_sql" name
+  end;
+  let exec = sprintf "T.%s db __sqlgg_sql %s %s" func params_binder_name callback in
   let exec =
     match
       List.find_map
@@ -454,9 +475,11 @@ let generate ~gen_io name stmts =
   in
 *)
   let (traits, io) =
-    match gen_io with
-    | true -> "Sqlgg_traits.M_io", "T.IO"
-    | false -> "Sqlgg_traits.M", "Sqlgg_io.Blocking"
+    match gen_io, !Sqlgg_config.tracing with
+    | true, false -> "Sqlgg_traits.M_io", "T.IO"
+    | false, false -> "Sqlgg_traits.M", "Sqlgg_io.Blocking"
+    | true, true -> "Sqlgg_traits.M_tracing_io", "T.IO"
+    | false, true -> "Sqlgg_traits.M_tracing", "Sqlgg_io.Blocking"
   in
   output "module %s (T : %s) = struct" (String.capitalize_ascii name) traits;
   empty_line ();

src/gen_xml.ml

@@ -97,19 +97,19 @@ let generate_code (x,_) index stmt =
   let sql = get_sql_string stmt in
   let attrs =
     match stmt.kind with
-    | Select `Nat      -> ["kind", "select"; "cardinality", "n"]
-    | Select `Zero_one -> ["kind", "select"; "cardinality", "0,1"]
-    | Select `One      -> ["kind", "select"; "cardinality", "1"]
-    | Insert (_, t)    -> ["kind", "insert"; "target", Sql.show_table_name t; "cardinality", "0"]
-    | Create t         -> ["kind", "create"; "target", Sql.show_table_name t; "cardinality", "0"]
-    | CreateIndex t    -> ["kind", "create_index"; "target",t;"cardinality","0"]
-    | Update None      -> ["kind", "update"; "cardinality", "0"]
-    | Update (Some t)  -> ["kind", "update"; "target", Sql.show_table_name t; "cardinality", "0"]
-    | Delete t         -> ["kind", "delete"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
-    | Alter t          -> ["kind", "alter"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
-    | Drop t           -> ["kind", "drop"; "target", Sql.show_table_name t; "cardinality", "0"]
-    | CreateRoutine s  -> ["kind", "create_routine"; "target", s]
-    | Other            -> ["kind", "other"]
+    | Select `Nat         -> ["kind", "select"; "cardinality", "n"]
+    | Select `Zero_one    -> ["kind", "select"; "cardinality", "0,1"]
+    | Select `One         -> ["kind", "select"; "cardinality", "1"]
+    | Insert (_, t)       -> ["kind", "insert"; "target", Sql.show_table_name t; "cardinality", "0"]
+    | Create t            -> ["kind", "create"; "target", Sql.show_table_name t; "cardinality", "0"]
+    | CreateIndex t       -> ["kind", "create_index"; "target",t;"cardinality","0"]
+    | Update None         -> ["kind", "update"; "cardinality", "0"]
+    | Update (Some t)     -> ["kind", "update"; "target", Sql.show_table_name t; "cardinality", "0"]
+    | Delete t            -> ["kind", "delete"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
+    | Alter t             -> ["kind", "alter"; "target", String.concat "," @@ List.map Sql.show_table_name t; "cardinality", "0"]
+    | Drop t              -> ["kind", "drop"; "target", Sql.show_table_name t; "cardinality", "0"]
+    | CreateRoutine (s,_) -> ["kind", "create_routine"; "target", s]
+    | Other               -> ["kind", "other"]
   in
   let nodes = [ input; output] in
   x := Node ("stmt", ("name",name)::("sql",sql)::("category",show_category @@ category_of_stmt_kind stmt.kind)::attrs, nodes) :: !x

src/sqlgg_config.ml

@@ -16,3 +16,6 @@ let debug1 () = !debug_level > 0
 let gen_header : [ `Full | `Without_timestamp | `Static ] option ref = ref (Some `Full)
 
 let include_category : [ `All | `None | `Only of Stmt.category list | `Except of Stmt.category list ] ref = ref `All
+
+
+let tracing : bool ref = ref false