diff --git a/bin/httui-lsp/httui_lsp.ml b/bin/httui-lsp/httui_lsp.ml index c3c2172..039bbbd 100644 --- a/bin/httui-lsp/httui_lsp.ml +++ b/bin/httui-lsp/httui_lsp.ml @@ -84,7 +84,10 @@ let values_for_uri uri = let publish_diagnostics uri text = let blocks = Httui_lang.Fence_scanner.scan text in let diagnostics = - Httui_lang.Analyze.diagnostics ~shapes:(shapes_for_uri uri) blocks + Httui_lang.Analyze.diagnostics ~shapes:(shapes_for_uri uri) + ~sql_tables_for:(fun connection_id -> + Sql_schema_store.tables_for ~connection_id) + ~doc:text blocks |> List.map (fun (d : Httui_lang.Analyze.diagnostic) -> T.Diagnostic.create ~range:(range_of_offsets text ~start:d.start_ ~stop:d.stop_) diff --git a/lib/analyze.ml b/lib/analyze.ml index b439437..4b46502 100644 --- a/lib/analyze.ml +++ b/lib/analyze.ml @@ -139,45 +139,148 @@ let field_diagnostic ~resolve (r : Refs.occurrence) segs = severity = Warning; } -let diagnostics ?(shapes = []) blocks = +(* --- cross-language ref-vs-column type check (db-* blocks) --------------- *) + +let comparison_ops = [ "="; "<>"; "!="; "<="; ">="; "<"; ">" ] + +(* Text strictly between byte offsets [a] and [b] (doc-absolute), trimmed. *) +let between text a b = + if b <= a || a < 0 || b > String.length text then "" + else String.trim (String.sub text a (b - a)) + +(* The data type of [col] across [tables]: the unique type when the column + name appears with a single category, else [None] (ambiguous columns are + skipped — leniency). *) +let column_category tables col = + let col = String.lowercase_ascii col in + let cats = + List.concat_map + (fun (t : Sql.table) -> + List.filter_map + (fun (c : Sql.column) -> + if String.lowercase_ascii c.name = col then + Option.map Sql_types.of_column c.data_type + else None) + t.columns) + tables + |> List.sort_uniq compare + in + match cats with [ c ] -> Some c | _ -> None + +(* For db-* block [b], pair each ref compared to a column (`col OP {{ref}}` + or `{{ref}} OP col`) and warn when their type categories are + incompatible. [resolve_type] turns a ref occurrence into its inferred + category (via the shape cache); [tables] is the connection's schema. *) +let sql_ref_diagnostics ~tables ~resolve_type doc (b : Block.t) = + let fields = + Sql.walk ~base:b.content_offset b.content + |> List.filter_map (fun (n : Sql.node) -> + if n.kind = "field" then + Some (String.sub doc n.start_ (n.stop_ - n.start_), n.start_, n.stop_) + else None) + in + Refs.of_block b + |> List.filter_map (fun (r : Refs.occurrence) -> + (* a column whose comparison operator sits in the gap to the ref, + on either side *) + let paired = + List.find_map + (fun (name, fs, fe) -> + if + fe <= r.ref_start + && List.mem (between doc fe r.ref_start) comparison_ops + then Some name + else if + r.ref_stop <= fs + && List.mem (between doc r.ref_stop fs) comparison_ops + then Some name + else None) + fields + in + match paired with + | None -> None + | Some col -> ( + match (column_category tables col, resolve_type r) with + | Some cat, Some ref_cat when not (Sql_types.compatible cat ref_cat) + -> + Some + { + start_ = r.name_start; + stop_ = r.ref_stop; + message = + Printf.sprintf + "Type mismatch: column '%s' is %s but {{%s}} is %s" col + (Sql_types.to_string cat) r.name + (Sql_types.to_string ref_cat); + severity = Warning; + } + | _ -> None)) + +let diagnostics ?(shapes = []) ?(sql_tables_for = fun _ -> []) ?(doc = "") + blocks = List.concat (List.mapi (fun i (b : Block.t) -> if not (Block.is_executable b) then [] else let scope = aliases_above blocks ~index:i in - Refs.of_block b - |> List.filter_map (fun (r : Refs.occurrence) -> - let typo_check () = - Option.bind - (typed_ctx ~shapes ~values:[] ~blocks ~index:i ~scope r.name) - (fun ctx -> - field_diagnostic ~resolve:ctx.resolve r (segments_of b r)) - in - if r.name = prev_name then - if prev_decl blocks ~index:i = None then + let ref_diags = + Refs.of_block b + |> List.filter_map (fun (r : Refs.occurrence) -> + let typo_check () = + Option.bind + (typed_ctx ~shapes ~values:[] ~blocks ~index:i ~scope + r.name) (fun ctx -> + field_diagnostic ~resolve:ctx.resolve r (segments_of b r)) + in + if r.name = prev_name then + if prev_decl blocks ~index:i = None then + Some + { + start_ = r.name_start; + stop_ = r.name_stop; + message = + "No previous block to reference with {{$prev}}"; + severity = Error; + } + else typo_check () + else if not r.has_path then None + else if not (List.mem_assoc r.name scope) then Some { start_ = r.name_start; stop_ = r.name_stop; - message = "No previous block to reference with {{$prev}}"; + message = + Printf.sprintf + "Unknown block alias '%s' — no block above declares \ + alias=%s" + r.name r.name; severity = Error; } - else typo_check () - else if not r.has_path then None - else if not (List.mem_assoc r.name scope) then - Some - { - start_ = r.name_start; - stop_ = r.name_stop; - message = - Printf.sprintf - "Unknown block alias '%s' — no block above declares \ - alias=%s" - r.name r.name; - severity = Error; - } - else typo_check ())) + else typo_check ()) + in + let sql_diags = + if not (is_db_lang b.lang) then [] + else + let connection_id = + if String.length b.lang > 3 then + String.sub b.lang 3 (String.length b.lang - 3) + else "" + in + let resolve_type (r : Refs.occurrence) = + Option.bind + (typed_ctx ~shapes ~values:[] ~blocks ~index:i ~scope r.name) + (fun ctx -> + match ctx.resolve (List.map fst (segments_of b r)) with + | Found shape -> + Some (Sql_types.of_shape_type (Shape.type_name shape)) + | _ -> None) + in + sql_ref_diagnostics + ~tables:(sql_tables_for connection_id) + ~resolve_type doc b + in + ref_diags @ sql_diags) blocks) let block_index_at blocks ~offset = diff --git a/lib/sql_types.ml b/lib/sql_types.ml new file mode 100644 index 0000000..1af24f2 --- /dev/null +++ b/lib/sql_types.ml @@ -0,0 +1,63 @@ +(* A small type lattice that normalises the many native SQL column types + (Postgres / MySQL / SQLite) and the inferred ref shape types down to a + handful of comparable categories. Used by the cross-language check: + `WHERE col = {{ref}}` warns when the column category and the ref category + are genuinely incompatible. Leniency is deliberate — a false squiggle + erodes trust faster than a missed one, so anything [Unknown] passes. *) + +type t = Number | String | Boolean | Json | Datetime | Unknown + +let to_string = function + | Number -> "number" + | String -> "string" + | Boolean -> "boolean" + | Json -> "json" + | Datetime -> "datetime" + | Unknown -> "unknown" + +let contains ~needle s = + let nl = String.length needle and sl = String.length s in + let rec go i = + if i + nl > sl then false + else if String.sub s i nl = needle then true + else go (i + 1) + in + nl = 0 || go 0 + +(* Column data-type string (from information_schema / PRAGMA) -> category. + Substring matching mirrors SQLite's affinity algorithm and covers the + common PG/MySQL spellings (int4, bigint, varchar, timestamptz, jsonb…). *) +let of_column raw = + let s = String.lowercase_ascii (String.trim raw) in + let has n = contains ~needle:n s in + if has "bool" then Boolean + else if has "json" then Json + else if + has "int" || has "serial" || has "numeric" || has "decimal" || has "real" + || has "double" || has "float" || has "money" + then Number + else if has "timestamp" || has "date" || has "time" then Datetime + else if + has "char" || has "text" || has "clob" || has "uuid" || has "string" + || has "enum" || has "name" + then String + else Unknown + +(* Inferred ref shape type name (Shape.type_name: "number" | "string" | + "boolean" | "null" | "object" | "array<…>") -> category. *) +let of_shape_type name = + match String.lowercase_ascii name with + | "number" -> Number + | "string" -> String + | "boolean" -> Boolean + | "object" -> Json + | s when String.length s >= 5 && String.sub s 0 5 = "array" -> Json + | _ -> Unknown + +(* Two categories are compatible unless both are known and different. + `Datetime` and `String` are treated as compatible (dates flow as ISO + strings on the value path). *) +let compatible a b = + a = b || a = Unknown || b = Unknown + || (a = Datetime && b = String) + || (a = String && b = Datetime) diff --git a/test/test_httui_lang.ml b/test/test_httui_lang.ml index bb50343..c6b975d 100644 --- a/test/test_httui_lang.ml +++ b/test/test_httui_lang.ml @@ -769,4 +769,45 @@ let () = (fun (c : Httui_lang.Sql.completion) -> c.is_table) (complete "SELECT * FROM ")); + (* --- cross-language ref-vs-column type check --- *) + let tc_shape = + Httui_lang.Shape.(Object_ [ ("body", Object_ [ ("id", Scalar "number") ]) ]) + in + let tc_tables col_type = + [ + Httui_lang.Sql. + { + schema = None; + name = "t"; + columns = [ { name = "email"; data_type = Some col_type } ]; + }; + ] + in + let tc_diags col_type = + let doc = + "```http alias=req1\n\ + GET /u\n\ + ```\n\n\ + ```db-pg\n\ + SELECT * FROM t WHERE email = {{req1.response.body.id}}\n\ + ```\n" + in + Httui_lang.Analyze.diagnostics + ~shapes:[ ("req1", tc_shape) ] + ~sql_tables_for:(fun _ -> tc_tables col_type) + ~doc + (Httui_lang.Fence_scanner.scan doc) + in + check "type mismatch (text column vs number ref) is flagged" + (List.exists + (fun (d : Httui_lang.Analyze.diagnostic) -> + has_sub d.message "Type mismatch" && has_sub d.message "email") + (tc_diags "text")); + check "compatible types (numeric column vs number ref) are not flagged" + (not + (List.exists + (fun (d : Httui_lang.Analyze.diagnostic) -> + has_sub d.message "Type mismatch") + (tc_diags "integer"))); + if !failures > 0 then exit 1