Minimal SQLite key-value store for OCaml
Fix PRIMARY KEY uniqueness, duplicate table names, and quoted names
- PRIMARY KEY on non-INTEGER columns now enforces UNIQUE (tests 91-93).
Added has_primary_key field to Ast.column_def; parse_unique_constraints
now treats both column-level and table-level PRIMARY KEY as UNIQUE.
- create_table rejects duplicate table names instead of silently creating
a second entry (test 97).
- Table.create ~name:"kv" reuses the existing default kv table instead of
creating a duplicate (test 98).
- Quoted table names ("my table", [my table], `my table`) are now properly
unquoted during CREATE TABLE parsing (test 99).
- Add memtrace instrumentation to test runner.
+67
-27
+4
-2
lib/ast.ml
+4
-2
lib/ast.ml
···
18
18
affinity : string;
19
19
is_rowid_alias : bool;
20
20
has_unique : bool;
21
+
has_primary_key : bool;
21
22
}
22
23
23
24
type create_table = {
···
83
84
| [] -> false
84
85
in
85
86
let has_unique = List.mem "UNIQUE" words in
87
+
let has_primary_key = has_pk words in
86
88
let is_rowid_alias =
87
-
String.uppercase_ascii affinity = "INTEGER" && has_pk words
89
+
String.uppercase_ascii affinity = "INTEGER" && has_primary_key
88
90
in
89
-
{ name; affinity; is_rowid_alias; has_unique }
91
+
{ name; affinity; is_rowid_alias; has_unique; has_primary_key }
+1
lib/ast.mli
+1
lib/ast.mli
+58
-23
lib/sqlite.ml
+58
-23
lib/sqlite.ml
···
151
151
Some (indices, String.concat ", " names)
152
152
else None
153
153
in
154
-
(* Table-level UNIQUE constraints *)
154
+
(* Table-level UNIQUE and PRIMARY KEY constraints *)
155
155
let table_level =
156
156
List.filter_map
157
-
(function Ast.Tbl_unique cols -> resolve_cols cols | _ -> None)
157
+
(function
158
+
| Ast.Tbl_unique cols | Ast.Tbl_primary_key cols ->
159
+
resolve_cols cols
160
+
| _ -> None)
158
161
ct.table_constraints
159
162
in
160
-
(* Column-level UNIQUE constraints *)
163
+
(* Column-level UNIQUE and non-rowid PRIMARY KEY constraints *)
161
164
let column_level =
162
165
List.filter_map
163
166
(fun (c : Ast.column_def) ->
164
-
if c.has_unique then resolve_cols [ c.name ] else None)
167
+
if c.has_unique || (c.has_primary_key && not c.is_rowid_alias) then
168
+
resolve_cols [ c.name ]
169
+
else None)
165
170
ct.columns
166
171
in
167
172
table_level @ column_level
···
854
859
then String.trim (String.sub s 13 (String.length s - 13))
855
860
else s
856
861
in
857
-
(* Extract name (up to space or paren) *)
858
-
let len =
859
-
let rec find i =
860
-
if i >= String.length s then i
861
-
else
862
-
match s.[i] with
863
-
| ' ' | '\t' | '\n' | '\r' | '(' -> i
864
-
| _ -> find (i + 1)
862
+
(* Extract name — handle quoted identifiers *)
863
+
if String.length s > 0 && (s.[0] = '"' || s.[0] = '[' || s.[0] = '`')
864
+
then
865
+
let close_char =
866
+
match s.[0] with '"' -> '"' | '[' -> ']' | _ -> '`'
865
867
in
866
-
find 0
867
-
in
868
-
String.sub s 0 len
868
+
let end_pos =
869
+
match String.index_from_opt s 1 close_char with
870
+
| Some i -> i
871
+
| None -> String.length s
872
+
in
873
+
String.sub s 1 (end_pos - 1)
874
+
else
875
+
let len =
876
+
let rec find i =
877
+
if i >= String.length s then i
878
+
else
879
+
match s.[i] with
880
+
| ' ' | '\t' | '\n' | '\r' | '(' -> i
881
+
| _ -> find (i + 1)
882
+
in
883
+
find 0
884
+
in
885
+
String.sub s 0 len
869
886
in
887
+
if List.exists (fun gt -> gt.g_schema.tbl_name = name) t.all_tables then
888
+
Fmt.failwith "table %S already exists" name;
870
889
let btree = Btree.Table.v t.pager in
871
890
let schema = { tbl_name = name; columns; sql } in
872
891
let constraints = parse_unique_constraints sql columns in
···
984
1003
match List.assoc_opt name parent.named_tables with
985
1004
| Some kv -> { parent; name; kv }
986
1005
| None ->
987
-
let kv = new_kv_table parent.pager in
988
-
let gt =
989
-
{
990
-
g_btree = kv.btree;
991
-
g_schema = kv_schema name;
992
-
g_unique_indexes = [];
993
-
}
1006
+
(* Check if a table with this name already exists (e.g. the default
1007
+
"kv" table or a table created via create_table). If so, reuse it
1008
+
as a named kv table rather than creating a duplicate. *)
1009
+
let existing_gt =
1010
+
List.find_opt
1011
+
(fun gt -> gt.g_schema.tbl_name = name)
1012
+
parent.all_tables
1013
+
in
1014
+
let kv =
1015
+
match existing_gt with
1016
+
| Some gt ->
1017
+
let keys, next_rowid = scan_table gt.g_btree in
1018
+
{ btree = gt.g_btree; keys; next_rowid }
1019
+
| None ->
1020
+
let kv = new_kv_table parent.pager in
1021
+
let gt =
1022
+
{
1023
+
g_btree = kv.btree;
1024
+
g_schema = kv_schema name;
1025
+
g_unique_indexes = [];
1026
+
}
1027
+
in
1028
+
parent.all_tables <- parent.all_tables @ [ gt ];
1029
+
kv
994
1030
in
995
1031
parent.named_tables <- (name, kv) :: parent.named_tables;
996
-
parent.all_tables <- parent.all_tables @ [ gt ];
997
1032
{ parent; name; kv }
998
1033
999
1034
(* Scan the B-tree for a key, returning (rowid, value) if found.
+1
-1
test/dune
+1
-1
test/dune