Add -line-directives

doc/_cli-options.md

@@ -6,6 +6,8 @@
   -category {all|none|[-]<category>{,<category>}+} Only generate code for these specific query categories (possible values: DDL DQL DML DCL TCL)
   -open <file>                                     Make definitions (schema, reusable queries) from <file> available without generating code for it (unless the file is also given as an input)
   -dynamic-select                                  Generate static and dynamic version for every SELECT (dynamic allows to pick columns per call)
+  -line-directives                                 Emit `# <line> "<file.sql>"` directives so that OCaml and merlin report errors in a generated query function on the line the query starts at (caml/caml_io only)
+  -line-directives-file <file>                     Name of the generated file, used by -line-directives to hand numbering back to it outside of query functions (default: <input.sql>.ml)
   -                                                Read sql from stdin
 
  Schema and migrations:

src/cli.ml

@@ -87,15 +87,12 @@ let parse_output s =
   | "none" -> None
   | _ -> failwith (sprintf "Unknown output language: %s" s)
 
-let stamp_source filename stmts =
-  List.map (fun (stmt : Gen.stmt) -> { stmt with props = Props.set stmt.props "file" filename }) stmts
-
 (* parse always runs for its schema-registration side effects, even in -gen none *)
 let read_statements = function
   | "-" -> Main.get_statements stdin
   | filename ->
-    Main.with_channel filename (Option.map_default Main.get_statements [])
-    |> stamp_source (Filename.basename filename)
+    Main.with_channel filename
+      (Option.map_default (Main.get_statements ~file:(Filename.basename filename)) [])
 
 let filter_stmts ~output stmts =
   match output with
@@ -339,6 +336,10 @@ let parse_args () =
       "-open", Arg.String open_input, "<file> Make definitions (schema, reusable queries) from <file> available without generating code for it (unless the file is also given as an input)";
       "-dynamic-select", Arg.Set Sqlgg_config.dynamic_select,
         " Generate static and dynamic version for every SELECT (dynamic allows to pick columns per call)";
+      "-line-directives", Arg.Set Sqlgg_config.line_directives,
+        " Emit `# <line> \"<file.sql>\"` directives so that OCaml and merlin report errors in a generated query function on the line the query starts at (caml/caml_io only)";
+      "-line-directives-file", Arg.String (fun s -> Sqlgg_config.line_directives_file := Some s),
+        "<file> Name of the generated file, used by -line-directives to hand numbering back to it outside of query functions (default: <input.sql>.ml)";
       "-", Arg.Unit (fun () -> work "-"), " Read sql from stdin";
     ] };
 
@@ -445,7 +446,9 @@ let parse_args () =
         inputs = List.rev !inputs;
       }
 
-let read_blocks f = Main.with_channel f (function Some ch -> Main.raw_blocks ch | None -> [])
+let read_blocks f =
+  Main.with_channel f (function Some ch -> Main.raw_blocks ch | None -> [])
+  |> List.map (fun (sql, props) -> sql, Props.set props "file" (Filename.basename f))
 
 let parse_migrations blocks =
   let migs = List.filter_map Main.migration_of_block blocks in

src/gen.ml

@@ -8,7 +8,9 @@ open Stmt
 
 type subst_mode = | Named | Unnamed | Oracle | PostgreSQL
 
-type stmt = { schema : Sql.schema_column list; vars : Sql.var list; kind : kind; props : Props.t; }
+type src = { file : string; line : int }
+
+type stmt = { schema : Sql.schema_column list; vars : Sql.var list; kind : kind; props : Props.t; src : src option }
 
 (** defines substitution function for parameter literals *)
 let params_mode = ref None
@@ -19,12 +21,28 @@ let (inc_indent,dec_indent,make_indent) =
   (fun () -> v := !v - 2),
   (fun () -> String.make !v ' ')
 
-let print_indent () = print_string (make_indent ())
-let indent s = print_indent (); print_string s
-let indent_endline s = print_indent (); print_endline @@ String.trim s
+let cur_src : src option ref = ref None
+let out_line = ref 1
+
+let emit s = print_string s; String.iter (function '\n' -> incr out_line | _ -> ()) s
+let directive line file = emit (sprintf "# %d %S\n" line file)
+
+let enter_src src = cur_src := if !Sqlgg_config.line_directives then src else None
+
+let leave_src () =
+  !cur_src |> Option.may (fun { file; _ } ->
+    cur_src := None;
+    let after_directive = !out_line + 1 in
+    directive after_directive (Option.default (file ^ ".ml") !Sqlgg_config.line_directives_file))
+
+let emit_line str =
+  Option.may (fun s -> directive s.line s.file) !cur_src;
+  emit str; emit "\n"
+let indent s = emit (make_indent ()); emit s
+let indent_endline s = emit_line (make_indent () ^ String.trim s)
 let output fmt = ksprintf indent_endline fmt
 let output_l = List.iter indent_endline
-let print fmt = ksprintf print_endline fmt
+let print fmt = ksprintf emit_line fmt
 let indented k = inc_indent (); k (); dec_indent ()
 
 let name_of attr index =

src/gen_caml.ml

@@ -115,7 +115,7 @@ let quote_comment_inline str =
 let make_comment str = "(* " ^ (quote_comment_inline str) ^ " *)"
 let comment () fmt = Printf.ksprintf (indent_endline $ make_comment) fmt
 
-let empty_line () = print_newline ()
+let empty_line () = emit "\n"
 
 let enums_hash_tbl = Hashtbl.create 100
 
@@ -342,16 +342,15 @@ let emit_cols_module ~brand_decl ~field_names body =
 let emit_verbatim_block src =
   let ind = make_indent () in
   String.split_on_char '\n' src
-  |> List.iter (fun line ->
-    if line = "" then print_newline ()
-    else Printf.printf "%s%s\n" ind line)
+  |> List.iter (fun line -> if line = "" then emit "\n" else emit_line (ind ^ line))
 
 let append_func_params ~has_callback ~module_kind inputs =
   inputs
   ^ (if has_callback then " callback" else "")
   ^ (if module_kind = `Fold then " acc" else "")
 
 let emit_func_header ~name ~extra_params ~has_callback ~format_input ~module_kind stmt =
+  enter_src stmt.src;
   let subst = Props.get_all stmt.props "subst" in
   let inputs = (subst @ names_of_vars stmt.vars) |> List.map format_input |> inline_values in
   output "let %s db%s %s =" name extra_params (append_func_params ~has_callback ~module_kind inputs);
@@ -401,6 +400,7 @@ let consumer = function
 let complete_func c =
   c.c_finish ();
   dec_indent ();
+  leave_src ();
   empty_line ()
 
 let make_variant_name i name ~is_poly =
@@ -1163,6 +1163,7 @@ let generate_dynamic_select_modules stmts =
           in
           let count_expr = eval_count_params field_args in
           let set_helper_name = sprintf "_set_%s" field_name in
+          enter_src stmt.Gen.src;
           begin match names_of_vars field_args with
           | [] -> output "let %s : _ t =" field_name
           | names -> output "let %s %s : _ t =" field_name (String.concat " " names)
@@ -1186,7 +1187,8 @@ let generate_dynamic_select_modules stmts =
               output "column = %s;" column_body;
               output "count = %s;" count_expr;
               output "deps = %s;" (deps_of_field field_schema));
-            output "}")
+            output "}");
+          leave_src ()
         in
         emit_cols_module ~brand_decl
           ~field_names:(List.map (fun f -> f.field_name) fields)
@@ -1280,17 +1282,18 @@ let generate_migrations name migrations =
     Gen.choose_name m.props m.kind index, m
   ) migrations in
   let migration_names = List.map fst named in
-  let make_stmt fn_name sql =
-    { Gen.schema = []; vars = []; kind = Stmt.Other;
+  let make_stmt ~src fn_name sql =
+    { Gen.schema = []; vars = []; kind = Stmt.Other; src;
       props = Props.set (Props.set Props.empty "name" fn_name) "sql" sql }
   in
   let revert_stmt name (m : Gen_migrations.migration) =
+    let make_stmt = make_stmt ~src:m.revert_src in
     match m.revert with
     | [] -> let s = make_stmt ("revert_" ^ name) "" in { s with props = Props.set s.props "noop" "" }
     | revert -> make_stmt ("revert_" ^ name) (String.concat ";\n" revert)
   in
   let stmts = List.concat_map (fun (name, (m : Gen_migrations.migration)) ->
-    [make_stmt ("apply_" ^ name) (String.concat ";\n" m.apply); revert_stmt name m]
+    [make_stmt ~src:m.apply_src ("apply_" ^ name) (String.concat ";\n" m.apply); revert_stmt name m]
   ) named in
   Option.may (Header.generate_header ()) !Sqlgg_config.gen_header;
   generate ~gen_io:true ~migration_names:(Some migration_names) name stmts

src/gen_migrations.ml

@@ -271,6 +271,8 @@ type migration = {
   kind : Stmt.kind;
   apply : string list;
   revert : string list;
+  apply_src : Gen.src option;
+  revert_src : Gen.src option;
 }
 
 let drop_type_sql type_name =

src/main.ml

@@ -113,7 +113,7 @@ let parse_one' (sql, props) =
     | _ -> ()
     end;
     let props = Props.set props "sql" sql in
-    { Gen.schema; vars; kind; props }
+    { Gen.schema; vars; kind; props; src = None }
 
 (** @return parsed statement or [None] in case of parsing failure.
     @raise exn for other errors (typing etc)
@@ -132,7 +132,7 @@ let stmt_has_dynamic_select (stmt : Gen.stmt) =
 
 let parse_one (sql, props as x) =
   match Props.get props "noparse" with
-  | Some _ -> [ { Gen.schema=[]; vars=[]; kind=Stmt.Other; props=Props.set props "sql" sql } ]
+  | Some _ -> [ { Gen.schema=[]; vars=[]; kind=Stmt.Other; props=Props.set props "sql" sql; src=None } ]
   | None ->
     match try_parse parse_one' x with
     | None -> []
@@ -191,15 +191,20 @@ end
 
 let lex_tokens lexbuf =
   Enum.from (fun () ->
-    if lexbuf.Lexing.lex_eof_reached then raise Enum.No_more_elements
-    else match Sql_lexer.ruleStatement lexbuf with
+    match Sql_lexer.ruleStatement lexbuf with
     | `Eof -> raise Enum.No_more_elements
-    | #token as x -> x)
+    | #token as x -> (x, Lexing.lexeme_start lexbuf))
+
+let lex_channel ch =
+  let source = Std.input_all ch in
+  let line = Array.make (String.length source + 1) 1 in
+  String.iteri (fun i c -> line.(i + 1) <- line.(i) + (if c = '\n' then 1 else 0)) source;
+  lex_tokens (Lexing.from_string source), Array.get line
 
 let extract_statement' tokens =
     let b = Buffer.create 1024 in
     let props = ref Props.empty in
-    let answer () = Buffer.contents b, !props in
+    let answer start = Buffer.contents b, !props, start in
 
     let internal_props = ref Props.empty in
 
@@ -210,39 +215,46 @@ let extract_statement' tokens =
       )
     in
 
-    let rec loop smth =
+    let rec loop start =
+      let started = Option.is_some start in
       match Enum.get tokens with
-      | None -> if smth then Some (answer ()) else None
-      | Some x ->
+      | None -> if started then Some (answer start) else None
+      | Some (x, off) ->
+        let content_start = if started then start else Some off in
         begin match x with
-        | `Comment _ -> loop smth
-        | `Char c -> flush_internal_props (); Buffer.add_char b c; loop true
-        | `Token s -> flush_internal_props (); Buffer.add_string b s; loop true
-        | `Space _ when smth = false -> loop smth
-        | `Space s -> Buffer.add_string b s; loop true
-        | `Props p when smth -> internal_props := Props.set_all p !internal_props; loop smth
-        | `Props p -> props := Props.set_all p !props; loop smth
-        | `Semicolon -> Some (answer ())
+        | `Comment _ -> loop start
+        | `Char c -> flush_internal_props (); Buffer.add_char b c; loop content_start
+        | `Token s -> flush_internal_props (); Buffer.add_string b s; loop content_start
+        | `Space _ when not started -> loop start
+        | `Space s -> Buffer.add_string b s; loop start
+        | `Props p when started -> internal_props := Props.set_all p !internal_props; loop start
+        | `Props p -> props := Props.set_all p !props; loop start
+        | `Semicolon -> Some (answer start)
         end
     in
     Parser_state.Stmt_metadata.reset();
-    try loop false
+    try loop None
     with e -> 
       Error.log "lexer failed (%s)" (Printexc.to_string e); 
       None
 
-let get_statements ch =
-  let lexbuf = Lexing.from_channel ch in
-  let tokens = lex_tokens lexbuf in
+let get_statements ?file ch =
+  let (tokens, line_at) = lex_channel ch in
   Enum.from (fun () ->
     match extract_statement' tokens with
     | Some x -> x
     | None -> raise Enum.No_more_elements)
-  |> Enum.map (fun (buffer, props) ->
+  |> Enum.map (fun (buffer, props, start) ->
+    let props = Option.map_default (Props.set props "file") props file in
+    let src = match file, start with
+      | Some file, Some off -> Some { Gen.file; line = line_at off }
+      | _ -> None
+    in
     let include_ = match Props.get props "include" with
       | Some s -> Include.of_string s
       | None -> Include.OnlyExecutable
     in
+    List.map (fun (stmt : Gen.stmt) -> { stmt with Gen.src }) @@
     match include_ with
     | OnlyReusable ->
       let (_: Sql.select_full option) = parse_select_one (buffer, props) in
@@ -255,21 +267,24 @@ let get_statements ch =
     | ReusableAndExecutable ->
       parse_select_one (buffer, props) |> Option.map_default (fun select_full ->
         let (schema, vars, kind) = Syntax.eval_select select_full in
-        let stmt = { Gen.schema; vars; kind; props = Props.set props "sql" buffer } in
+        let stmt = { Gen.schema; vars; kind; props = Props.set props "sql" buffer; src = None } in
         check_statement stmt buffer; [stmt]) []
   ) |> List.of_enum |> List.concat
 
 let replay_sql sql = ignore (try_parse parse_one' (sql, Props.empty))
 
 let collect_blocks ch =
-  let lexbuf = Lexing.from_channel ch in
-  let tokens = lex_tokens lexbuf in
+  let (tokens, line_at) = lex_channel ch in
   let rec aux acc =
     match extract_statement' tokens with
     | None -> List.rev acc
-    | Some (buffer, props) ->
+    | Some (buffer, props, start) ->
       let b = String.trim buffer in
-      if b = "" then aux acc else aux ((b, props) :: acc)
+      if b = "" then aux acc else
+      let props =
+        Option.map_default (fun off -> Props.set props "line" (string_of_int (line_at off))) props start
+      in
+      aux ((b, props) :: acc)
   in
   aux []
 
@@ -279,6 +294,7 @@ let glue_downs blocks =
     | (sql, props) :: (down_sql, down_props) :: rest
       when has "id" props && not (has "down" props) && not (has "irreversible" props)
            && not (has "id" down_props) ->
+      let props = Option.map_default (Props.set props "down_line") props (Props.get down_props "line") in
       (sql, Props.set props "down" down_sql) :: aux rest
     | b :: rest -> b :: aux rest
     | [] -> []
@@ -313,7 +329,13 @@ let migration_of_block (sql, props) =
          | _ -> stmt.props)
       | _ -> stmt.props
     in
-    { Gen_migrations.props; kind = stmt.kind; apply = [apply]; revert })
+    let src key =
+      match Props.get props "file", Props.get props key with
+      | Some file, Some line -> Option.map (fun line -> { Gen.file; line }) (int_of_string_opt line)
+      | _ -> None
+    in
+    { Gen_migrations.props; kind = stmt.kind; apply = [apply]; revert;
+      apply_src = src "line"; revert_src = src "down_line" })
 
 let with_channel filename f =
   match try Some (open_in filename) with _ -> None with

src/schema_diff.ml

@@ -293,7 +293,8 @@ let generate ~naming ~ddl_as_migration ~from_ ~to_ =
   let by_from = table_by_name from_ in
   let by_to = table_by_name to_ in
   diff ~ddl_as_migration ~from_ ~to_ ~by_from ~by_to |> List.map (fun up ->
-    { Gen_migrations.props = Props.set Props.empty "name" (change_name ~naming up);
+    { Gen_migrations.apply_src = None; revert_src = None;
+      props = Props.set Props.empty "name" (change_name ~naming up);
       kind = kind_of_change up;
       apply = render_apply up;
       revert = render_apply (invert ~by_from ~by_to up) })

src/sqlgg_config.ml

@@ -24,3 +24,7 @@ let no_check_features: Dialect.feature list ref = ref []
 let set_no_check_features l = no_check_features := l
 
 let allow_write_notnull_null b = Syntax.Config.allow_write_notnull_null := b
+
+let line_directives = ref false
+
+let line_directives_file : string option ref = ref None

src/test.ml

@@ -21,15 +21,9 @@ let cmp_params p1 p2 =
     _ -> false
 
 let parse sql =
-  let lexbuf = Lexing.from_string sql in
-  let tokens = Enum.from (fun () ->
-    match Sql_lexer.ruleStatement lexbuf with
-    | `Eof -> `Semicolon
-    | #Main.token as x -> x)
-  in
-  match Main.extract_statement' tokens with
+  match Main.extract_statement' (Main.lex_tokens (Lexing.from_string sql)) with
   | None -> raise Enum.No_more_elements 
-  | Some (buffer, _) ->
+  | Some (buffer, _, _) ->
       match Main.parse_one (buffer,[]) with
       | exception exn -> assert_failure @@ sprintf "failed : %s : %s" (Printexc.to_string exn) sql
       | [] -> assert_failure @@ sprintf "Failed to parse : %s" sql

test/cram/line_directives.t/dyn.sql

@@ -0,0 +1,7 @@
+CREATE TABLE items (id INT NOT NULL PRIMARY KEY, name TEXT NULL);
+
+-- [sqlgg] dynamic_select=true
+-- @pick
+SELECT id, name
+  FROM items
+ WHERE id = @id;

test/cram/line_directives.t/extends.sql

@@ -0,0 +1,6 @@
+-- [sqlgg] manual
+-- [sqlgg] id=20260609000000
+ALTER TABLE users
+  RENAME COLUMN email TO email_address;
+ALTER TABLE users
+  RENAME COLUMN email_address TO email;

test/cram/line_directives.t/initial.sql

@@ -0,0 +1 @@
+CREATE TABLE users (id INT NOT NULL, email TEXT NOT NULL);