8 type t
= | Int
| Text
| Blob
| Float
| Bool
| Datetime
| Any
11 let to_string = Show.show
<t
>
15 | Any
, _
| _
, Any
-> true
19 | Group
of t
* bool (* 'a -> t ; bool = multi-column *)
21 | Fixed
of t
* t list
(* ret, params *)
22 | Poly
of t
(* 'a -> 'a -> t *)
23 | Ret
of t
(* _ -> t *)
25 module Show_func
= struct
28 | Group
(ret
,multi
) -> sprintf
"|%s'a| -> %s" (if multi
then "{...} as " else "") (to_string ret
)
29 | Fixed
(ret
, args
) -> sprintf
"%s -> %s" (String.concat
" -> " @@ List.map
to_string args
) (to_string ret
)
30 | Poly ret
-> sprintf
"'a -> 'a -> %s" (to_string ret
)
31 | Ret ret
-> sprintf
"_ -> %s" (to_string ret
)
32 let format pp x
= Format.fprintf pp
"%s" (show x
)
35 let string_of_func = Show_func.show
37 let is_grouping = function
38 | Group _
| Agg
-> true
39 | Fixed _
| Ret _
| Poly _
-> false
44 type conflict_algo
= | Ignore
| Replace
| Abort
| Fail
| Rollback
47 type t
= | PrimaryKey
| NotNull
| Unique
| Autoincrement
| OnConflict
of conflict_algo
51 type attr
= {name
: string; domain
: Type.t
;}
54 let attr n d
= {name
=n
;domain
=d
}
61 exception Error
of t
* string
63 (** FIXME attribute case sensitivity? *)
64 let by_name name
= function attr -> attr.name
= name
65 let find_by_name t name
= List.find_all
(by_name name
) t
68 match find_by_name t name
with
70 | [] -> raise
(Error
(t
,"missing attribute : " ^ name
))
71 | _
-> raise
(Error
(t
,"duplicate attribute : " ^ name
))
73 let make_unique = List.unique ~cmp
:(fun a1 a2
-> a1
.name
= a2
.name
&& a1
.name
<> "")
74 let is_unique t
= List.length
(make_unique t
) = List.length t
75 let check_unique t
= is_unique t
|| raise
(Error
(t
,"duplicate attributes"))
77 let project names t
= List.map
(find t
) names
79 let change_inplace t before after
=
81 match by_name before
attr with
85 let cross t1 t2
= t1
@ t2
87 (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
88 let contains t
attr = find t
attr.name
= attr
90 let check_contains t
attr =
91 if not
(contains t
attr) then
92 raise
(Error
(t
,"type mismatch for attribute " ^
attr.name
))
94 let sub l a
= List.filter
(fun x
-> not
(List.mem x a
)) l
96 let to_string v
= v
|> List.map
(fun attr -> sprintf
"%s %s" (Type.to_string attr.domain
) attr.name
) |>
97 String.concat
", " |> sprintf
"[%s]"
98 let names t
= t
|> List.map
(fun attr -> attr.name
) |> String.concat
"," |> sprintf
"[%s]"
101 let (common
,t1only
) = List.partition
(fun x
-> List.mem x t2
) t1
in
102 if 0 = List.length common
then failwith
"natural'";
103 let t2only = sub t2 common
in
104 common
@ t1only
@ t2only
107 try natural_ t1 t2
with
108 | _
-> raise
(Error
(t1
,"no common attributes for natural join of " ^
109 (names t1
) ^
" and " ^
(names t2
)))
111 let join_using l t1 t2
=
112 let common = List.map
(find t1
) l
in
113 List.iter
(check_contains t2
) common;
114 common @ sub t1
common @ sub t2
common
116 let check_types t1 t2
=
117 List.iter2
(fun a1 a2
->
118 match a1
.domain
, a2
.domain
with
121 | x
, y
when x
= y
-> ()
122 | _
-> raise
(Error
(t1
, sprintf
"Atributes do not match : %s of type %s and %s of type %s"
123 a1
.name
(Type.to_string a1
.domain
)
124 a2
.name
(Type.to_string a2
.domain
)))) t1 t2
126 let check_types t1 t2
=
127 try check_types t1 t2
with
128 | List.Different_list_size _
-> raise
(Error
(t1
, (to_string t1
) ^
" differs in size to " ^
(to_string t2
)))
130 let compound t1 t2
= check_types t1 t2
; t1
133 match find_by_name t col
.name
with
138 | `Default
-> t
@ [col
]
141 let (i
,_
) = List.findi
(fun _
attr -> by_name name
attr) t
in
142 let (l1
,l2
) = List.split_nth
(i
+1) t
in
145 Not_found
-> raise
(Error
(t
,"Can't insert column " ^ col
.name ^
" after non-existing column " ^ name
))
147 | _
-> raise
(Error
(t
,"Already has column " ^ col
.name
))
151 List.remove_if
(by_name col
) t
153 let change t oldcol col pos
=
155 | `Default
-> change_inplace t oldcol col
156 | `First
| `After _
-> add (drop t oldcol
) col pos
158 let to_string x
= Show.show<t
>(x
)
159 let print x
= prerr_endline
(to_string x
)
163 type table
= string * Schema.t deriving
(Show
)
164 type schema
= Schema.t
166 let print_table out
(name
,schema
) =
167 IO.write_line out name
;
168 schema
|> List.iter
(fun {name
=name
;domain
=domain
} ->
169 IO.printf out
"%10s %s\n" (Type.to_string domain
) name
);
172 (** optional name and start/end position in string *)
173 type param_id
= string option * (int * int) deriving
(Show
)
174 type param
= param_id
* Type.t deriving
(Show
)
175 type params
= param list deriving
(Show
)
177 let params_to_string ps
= Show.show<params
>(ps
)
179 type alter_pos
= [ `After
of string | `Default
| `First
]
180 type alter_action
= [ `Add
of attr * alter_pos
| `Drop
of string | `Change
of string * attr * alter_pos
| `None
]
182 type select_result
= (schema
* param list
)
184 type col_name
= string * string option (* column name + table name *)
186 type int_or_param
= [`Const
of int | `Limit
of param
]
187 type limit_t
= [ `Limit
| `Offset
]
188 type limit
= ((string option * (int * int)) * Type.t
) list
* bool
189 and source1
= [ `Select
of select
| `Table
of string ]
190 and source
= source1
* string option
191 and join_cond
= [ `Cross
| `Search
of expr
| `Default
| `Natural
| `Using
of string list
]
193 columns
: column list
;
194 from
: (source
* (source
* join_cond
) list
) option;
197 having
: expr
option;
199 and select_full
= select
* select list
* expr list
* limit
option
201 | Value
of Type.t
(** literal value *)
203 | Fun
of Type.func
* expr list
(** parameters *)
204 | Select
of select_full
* bool (* single *)
205 | Column
of (string * string option) (** name, table *)
209 | Expr
of expr
* string option (** name *)
212 type columns
= column list deriving
(Show
)
214 type expr_q
= [ `Value
of Type.t
(** literal value *)
216 | `Func
of Type.func
* expr_q list
(** return type, grouping, parameters *)
220 let expr_to_string = Show.show<expr
>
223 | Create
of string * [ `Schema
of schema
| `Select
of select_full
]
225 | Alter
of string * alter_action list
226 | CreateIndex
of string * string * string list
(* index name, table name, columns *)
228 [ `Set
of (col_name
* expr
) list
option
229 | `Values
of (string list
option * expr list
option)
230 | `Select
of (string list
option * select_full
) ]
231 | Delete
of string * expr
option
232 | Set
of string * expr
233 | Update
of string * (col_name
* expr
) list
* expr
option * expr list
* param list
(* where, order, limit *)
234 | UpdateMulti
of source list
* (col_name
* expr
) list
* expr
option
235 | Select
of select_full
240 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
243 let () = print (project ["b";"c";"b"] test)
244 let () = print (project ["b";"d"] test)
245 let () = print (rename test "a" "new_a")