diff --git a/NEWS b/NEWS index 42bc5e1..709fdfe 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,5 @@ 0.3: +* Add support for index (both lookup and unique) [2 Oct 2009] * Rewrite to a camlp4 (3.11+) code base and remove old extension [26 Sep 2009] 0.2: diff --git a/TODO b/TODO index a3a96b0..6343cf8 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,3 @@ -- create indexes - foreign keys (Frefs) - no fold - let type t work via type alias (clashes with Functor atm) diff --git a/lib/pa_orm.ml b/lib/pa_orm.ml index 451c107..903fed6 100644 --- a/lib/pa_orm.ml +++ b/lib/pa_orm.ml @@ -701,7 +701,15 @@ module Init = struct } >> ) (sql_tables env)) in - <:expr< do { $create_exs$; $trigger_exs$; $cache_trigger_exs$ } >> + + let create_indices = Ast.exSem_of_list (List.map (fun (unique,t,fs) -> + let s = sprintf "CREATE %sINDEX IF NOT EXISTS idx_%s_%s ON %s (%s);" + (match unique with true -> "UNIQUE " |false -> "") + t (String.concat "_" fs) t (String.concat "," fs) in + <:expr< OS.db_must_ok db (fun () -> Sqlite3.exec db.OS.db $str:s$) >> + ) env.e_indices) in + + <:expr< do { $create_exs$; $trigger_exs$; $cache_trigger_exs$; $create_indices$ } >> (* construct custom trigger function to delete ids/values from the weak hash after a delete has gone through *) @@ -769,13 +777,14 @@ end module Syntax = struct (* Extend grammar with options for SQL tables *) type p_keys = - | Unique of string list + | Unique of (bool * string * string list) list (* unique, table, fields *) | Debug of string list | Dot of string | Name of string let string_of_p_keys = function - | Unique sl -> "unique: " ^ ( String.concat "," sl ) + | Unique sl -> "unique: " ^ ( String.concat "," + (List.map (fun (u,x,y) -> sprintf "%s(%s:%b)" x (String.concat "," y) u) sl )) | Debug d -> "debug: " ^ (String.concat "," d) | Dot f -> "dot: " ^ f | Name n -> "name: " ^ n @@ -785,12 +794,15 @@ module Syntax = struct GLOBAL: orm_parms; - orm_svars: [ - [ l = LIST0 [ `LIDENT(x) -> x ] SEP "," -> l ] - ]; + orm_svars: [[ l = LIST1 [ `LIDENT(x) -> x ] SEP "," -> l ]]; + + orm_table: [[ x = LIDENT; "<"; y = orm_svars; ">" -> (x, y) ]]; + + orm_tables: [[ l = LIST1 [ orm_table ] SEP "," -> l ]]; orm_param: [[ - "unique"; ":" ; x = orm_svars -> Unique x + "unique"; ":" ; x = orm_tables -> Unique (List.map (fun (x,y) -> (true,x,y)) x) + | "index"; ":" ; x = orm_tables -> Unique (List.map (fun (x,y) -> (false,x,y)) x) | "debug"; ":" ; x = orm_svars -> Debug x | "dot"; ":" ; x = STRING -> Dot x | "modname";":" ; x = STRING -> Name x @@ -804,7 +816,7 @@ module Syntax = struct let parse_keys = List.fold_left (fun env -> function - |Unique fl -> { env with e_unique = fl :: env.e_unique } + |Unique fl -> { env with e_indices = fl @ env.e_indices } |Name n -> { env with e_name=n } |Debug modes -> List.fold_left (fun env -> function |"sql" -> { env with debug_sql=true } diff --git a/lib/sql_types.ml b/lib/sql_types.ml index fbf3333..fb93fbe 100644 --- a/lib/sql_types.ml +++ b/lib/sql_types.ml @@ -52,7 +52,7 @@ type field_info = and env = { e_tables: table list; e_types: (string * ctyp) list; - e_unique: string list list; + e_indices: (bool * string * string list) list; e_name: string; debug_sql: bool; debug_binds: bool; @@ -134,7 +134,7 @@ let dot_of_env e = (* --- Helper functions to manipulate environment *) -let empty_env () = { e_tables = []; e_types=[]; e_unique=[]; e_name="orm"; +let empty_env () = { e_tables = []; e_types=[]; e_indices=[]; e_name="orm"; debug_sql=false; debug_binds=false; debug_cache=false; debug_dot=None } let find_table env name = diff --git a/lib_test/foreign.ml b/lib_test/foreign.ml index f51df96..e0179fb 100644 --- a/lib_test/foreign.ml +++ b/lib_test/foreign.ml @@ -13,7 +13,9 @@ and x = { third: int; } with orm ( - debug:sql + debug:sql; + unique: s, s; + index: x ) let name = "foreign.db" diff --git a/lib_test/simple.ml b/lib_test/simple.ml index fa2f920..446bea5 100644 --- a/lib_test/simple.ml +++ b/lib_test/simple.ml @@ -8,6 +8,7 @@ type x = { bar: string } with orm( + unique: x, x; debug: all; dot: "simple.dot"; modname: "My_simple"