Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
53 changes: 14 additions & 39 deletions lib/dialect.ml
Original file line number Diff line number Diff line change
Expand Up @@ -164,25 +164,18 @@ let get_default_expr ~kind ~expr pos =
let rec analyze = function
| Value _ -> (true, false, true)
| Column _ -> (true, true, false)
| Case { case; branches; else_ } ->
let parts = option_list case @ option_list else_ in
let parts = parts @ List.concat_map (fun { Sql.when_; then_ } -> [when_; then_]) branches in
List.fold_left
(fun (v_acc, c_acc, o_acc) e ->
let v, c, o = analyze e in
(v_acc && v, c_acc || c, o_acc && o))
(true, false, true)
parts
| Fun { parameters; _ } ->
List.fold_left
(fun (v_acc, c_acc, o_acc) e ->
let v, c, o = analyze e in
(v_acc && v, c_acc || c, o_acc && o))
(true, false, true)
parameters
| ( Param _ | Inparam _ | Choices _ | InChoice _
| SelectExpr _ | InTupleList _ | OptionActions _ | Of_values _ ) ->
| Case _ as e -> fold_parts (sub_exprs e)
| Fun { parameters; _ } -> fold_parts parameters
| Param _ | Inparam _ | Choices _ | InChoice _
| SelectExpr _ | InTupleList _ | OptionActions _ | Of_values _ ->
(false, false, false)
and fold_parts parts =
List.fold_left
(fun (v_acc, c_acc, o_acc) e ->
let v, c, o = analyze e in
(v_acc && v, c_acc || c, o_acc && o))
(true, false, true)
parts
in
let valid, has_column, only_value = analyze expr in
if not valid then only DefaultExpr [] pos
Expand All @@ -205,11 +198,7 @@ let get_default_expr ~kind ~expr pos =
| _ -> all
in
let dialects =
base_dialects
|> List.to_seq
|> Seq.filter (fun d -> not (has_column && d = PostgreSQL))
|> Seq.filter (fun d -> only_value || d <> SQLite)
|> List.of_seq
List.filter (fun d -> not (has_column && d = PostgreSQL) && (only_value || d <> SQLite)) base_dialects
in
only DefaultExpr dialects pos

Expand Down Expand Up @@ -239,26 +228,12 @@ let rec analyze_expr acc exprs k = match exprs with
| [] -> k acc
| expr :: rest ->
match expr with
| Value _ | Param _ | Inparam _ | Column _ | Of_values _ ->
analyze_expr acc rest k
| Choices (_, choices) ->
let new_exprs = List.filter_map (fun (_, expr_opt) -> expr_opt) choices in
analyze_expr acc (new_exprs @ rest) k
| InChoice (_, _, e) ->
analyze_expr acc (e :: rest) k
| Fun { parameters; _ } ->
analyze_expr acc (parameters @ rest) k
| SelectExpr (select_full, _) ->
analyze_select_full acc [select_full] (fun acc -> analyze_expr acc rest k)
| InTupleList { value = { exprs; _ }; _ } ->
analyze_expr acc (exprs @ rest) k
| OptionActions { choice; _ } ->
analyze_expr acc (choice :: rest) k
| Case { case; branches; else_ } ->
let case_exprs = option_list case in
let branches_exprs = List.concat_map (fun { when_; then_ } -> [when_; then_]) branches in
let else_exprs = option_list else_ in
analyze_expr acc (case_exprs @ branches_exprs @ else_exprs @ rest) k
| e ->
analyze_expr acc (sub_exprs e @ rest) k

and analyze_column acc cols k = match cols with
| [] -> k acc
Expand Down
104 changes: 98 additions & 6 deletions lib/sql.ml
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ open Printf
open ExtLib
open Prelude

type pos = (int * int) [@@deriving show]
type pos = int * int [@@deriving show]

type 'a located = { value : 'a; pos : pos } [@@deriving show, make]
type 'a collated = { collated: 'a; collation: string located option } [@@deriving show, make]
Expand Down Expand Up @@ -328,6 +328,17 @@ end
type attr = {name : string; domain : Type.t; extra : Constraints.t; meta: Meta.t; }
[@@deriving show {with_path=false}]

let unique_keys schema =
let keys_of a =
Constraints.fold (fun c acc ->
match c with
| Constraint.PrimaryKey | Unique -> Constraint.StringSet.singleton a.name :: acc
| Composite (CompositePrimary s | CompositeUnique s) -> s :: acc
| NotNull | Null | Autoincrement | OnConflict _ | WithDefault -> acc)
a.extra []
in
List.concat_map keys_of schema |> List.sort_uniq Constraint.StringSet.compare

let make_attribute name kind extra ~meta =
if Constraints.mem Null extra && Constraints.mem NotNull extra then fail "Column %s can be either NULL or NOT NULL, but not both" name;
let domain = Type.{ t = Option.default Int kind; nullability = if List.exists (fun cstrt -> Constraints.mem cstrt extra) [NotNull; PrimaryKey]
Expand All @@ -350,6 +361,8 @@ struct
type 'a t = { attr: attr; sources: 'a list } [@@deriving show]

let by_name name sattr = sattr.attr.name = name

let map_attr f sattr = { sattr with attr = f sattr.attr }
end

type 'a t = 'a Attr.t list
Expand Down Expand Up @@ -463,7 +476,7 @@ struct
List.combine t1 t2
|> List.mapi begin fun i (a1,a2) ->
match Type.supertype a1.attr.domain a2.attr.domain with
| Some t -> { a1 with attr = { a1.attr with domain=t } }
| Some t -> Attr.map_attr (fun attr -> { attr with domain = t }) a1
| None -> raise (Error (List.map (fun i -> i.attr) t1, sprintf "Attributes do not match : %s of type %s and %s of type %s"
(show_name i a1.attr) (Type.show a1.attr.domain)
(show_name i a2.attr) (Type.show a2.attr.domain)))
Expand Down Expand Up @@ -506,6 +519,9 @@ let make_table_name ?db tn = { db; tn }
type schema = Schema.t [@@deriving show]
type table = table_name * schema [@@deriving show]

type join_source = { table : table_name; alias : table_name option } [@@deriving show]
let join_source_name { table; alias } = Option.default table alias

let print_table out (name,schema) =
IO.write_line out (show_table_name name);
schema |> List.iter begin fun {name;domain;extra;_} ->
Expand Down Expand Up @@ -569,6 +585,7 @@ and var =
| ChoiceIn of { param: param_id; kind : in_or_not_in; vars: var list }
| Choice of param_id * ctor list
| DynamicSelect of param_id * ctor list
| DynamicSelectJoin of { pid : param_id; pos : pos; source : join_source }
| TupleList of param_id * tuple_list_kind
(* It differs from Choice that in this case we should generate sql "TRUE", it doesn't seem reusable *)
| OptionActionChoice of param_id * var list * (pos * pos) * option_actions_kind
Expand All @@ -580,6 +597,38 @@ and tuple_list_kind =
[@@deriving show]
and vars = var list [@@deriving show]

let ctor_vars = function
| Simple (_, vars) -> Option.default [] vars
| Verbatim _ -> []

let sub_vars = function
| Single _ | SingleIn _ | TupleList _ | DynamicSelectJoin _ -> []
| ChoiceIn { vars; _ } -> vars
| OptionActionChoice (_, vars, _, _) -> vars
| SharedVarsGroup (vars, _) -> vars
| Choice (_, ctors) | DynamicSelect (_, ctors) -> List.concat_map ctor_vars ctors

let map_sub_vars f =
let map_ctor = function
| Simple (n, vars) -> Simple (n, Option.map f vars)
| Verbatim _ as c -> c
in
function
| Single _ | SingleIn _ | TupleList _ | DynamicSelectJoin _ as v -> v
| ChoiceIn t -> ChoiceIn { t with vars = f t.vars }
| OptionActionChoice (p, vars, pos, kind) -> OptionActionChoice (p, f vars, pos, kind)
| SharedVarsGroup (vars, id) -> SharedVarsGroup (f vars, id)
| Choice (p, ctors) -> Choice (p, List.map map_ctor ctors)
| DynamicSelect (p, ctors) -> DynamicSelect (p, List.map map_ctor ctors)

let var_pos = function
| Single (p, _) | SingleIn (p, _) -> fst p.id.pos
| Choice (id, _) | DynamicSelect (id, _) | TupleList (id, _)
| OptionActionChoice (id, _, _, _) -> fst id.pos
Comment on lines +604 to +627

Copy link
Copy Markdown
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

#284 (comment)
taken out separately for the same reason

| ChoiceIn { param; _ } -> fst param.pos
| SharedVarsGroup (_, id) -> fst id.pos
| DynamicSelectJoin { pos = (j1, _); _ } -> j1

type alter_pos = [ `After of string | `Default | `First ] [@@deriving show {with_path=false}]

type direction = [ `Fixed | `Param of param_id ] [@@deriving show]
Expand Down Expand Up @@ -701,6 +750,40 @@ let source_fun_kind_to_infer = function

let expr_to_string = show_expr

let sub_exprs = function
| Value _ | Param _ | Inparam _ | Column _ | Of_values _ | SelectExpr _ -> []
| Choices (_, l) -> List.filter_map snd l
| InChoice (_, _, e) -> [e]
| OptionActions { choice; _ } -> [choice]
| Fun { kind = Agg (With_order { order; _ }); parameters; _ } -> parameters @ List.map fst order
| Fun { parameters; _ } -> parameters
| InTupleList { value = { exprs; _ }; _ } -> exprs
| Case { case; branches; else_ } ->
option_list case
@ List.concat_map (fun (b : case_branch) -> [b.when_; b.then_]) branches
@ option_list else_

let map_sub_exprs f = function
| Value _ | Param _ | Inparam _ | Column _ | Of_values _ | SelectExpr _ as e -> e
| Choices (n, l) -> Choices (n, List.map (fun (n, e) -> n, Option.map f e) l)
| InChoice (n, k, e) -> InChoice (n, k, f e)
| OptionActions ({ choice; _ } as o) -> OptionActions { o with choice = f choice }
| Fun ({ kind = Agg (With_order ({ order; _ } as wo)); parameters; _ } as fn) ->
Fun { fn with
kind = Agg (With_order { wo with order = List.map (fun (e, dir) -> f e, dir) order });
Comment on lines +753 to +773

Copy link
Copy Markdown
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I was writing a tree walkthrough again and realized this is time to move it to a separate place.
Besides, adding a new expression forces us to go through every places adding a new match

https://gitlab.inria.fr/fpottier/visitors
and by the way it’s even easier to get all these maps and traverses by adding this ppx

parameters = List.map f parameters }
| Fun ({ parameters; _ } as fn) -> Fun { fn with parameters = List.map f parameters }
| InTupleList ({ value = { exprs; _ } as tl; _ } as loc) ->
InTupleList { loc with value = { tl with exprs = List.map f exprs } }
| Case { case; branches; else_ } ->
Case {
case = Option.map f case;
branches = List.map (fun (b : case_branch) -> { when_ = f b.when_; then_ = f b.then_ }) branches;
else_ = Option.map f else_;
}

let rec expr_exists p e = p e || List.exists (expr_exists p) (sub_exprs e)

let make_partition_by = List.iter (function
| Value _ -> fail "ORDER BY or PARTITION BY uses legacy position indication which is not supported, use expression."
| _ -> ())
Expand Down Expand Up @@ -784,7 +867,7 @@ module Alter_action_attr = struct
make_located ~pos:(0,0) ~value:c
) in
let kind = Some (make_located ~pos:(0,0) ~value:(make_collated ~collated:(Source_type.Infer attr.domain.Type.t) ())) in
let meta = Meta.StringMap.to_seq attr.meta |> List.of_seq in
let meta = Meta.StringMap.bindings attr.meta in
{ name = attr.name; kind; extra; meta }
end

Expand Down Expand Up @@ -852,19 +935,28 @@ let () = print (project ["b";"d"] test)
let () = print (rename test "a" "new_a")
*)

type 'attr dynamic_field = {
field_id : param_id;
field_attr : 'attr;
join_deps : int list;
}
[@@deriving show]

type schema_column_with_sources =
| AttrWithSources of table_name Schema.Source.Attr.t
| DynamicWithSources of param_id * (param_id * table_name Schema.Source.Attr.t) list
| DynamicWithSources of param_id * table_name Schema.Source.Attr.t dynamic_field list
[@@deriving show]

type schema_column =
| Attr of attr
| Dynamic of param_id * (param_id * attr) list
| Dynamic of param_id * attr dynamic_field list
[@@deriving show]

let drop_sources : schema_column_with_sources -> schema_column = function
| AttrWithSources { attr; _ } -> Attr attr
| DynamicWithSources (p, l) -> Dynamic (p, List.map (fun (p, { Schema.Source.Attr.attr; _ }) -> p, attr) l)
| DynamicWithSources (p, l) ->
Dynamic (p, List.map (fun { field_id; field_attr = { Schema.Source.Attr.attr; _ }; join_deps } ->
{ field_id; field_attr = attr; join_deps }) l)

let monomorphic ret args = F (Typ ret, List.map (fun t -> Type.Typ t) args)
let fixed ret args = monomorphic (Type.depends ret) (List.map Type.depends args)
Expand Down
Loading