Skip to content
Browse files

[enhance] compiler: (big) Added more update and query node + added ty…

…ping of query and update node + imrove schema analysis
  • Loading branch information...
1 parent 6ada700 commit c197c0f7d98f97d25d0fcabdd755662b7363b2ba @BourgerieQuentin BourgerieQuentin committed Jan 24, 2012
View
4 libqmlcompil/dbGen/dbGen_private.ml
@@ -102,8 +102,8 @@ module Default = struct
else
match (V.label n).C.nlabel with
| C.Multi -> (match SchemaGraphLib.multi_key sch n with
- | C.Kint -> assert false
- | C.Kstring -> assert false
+ | C.Kint -> H.make_record ["empty", H.make_record []]
+ | C.Kstring -> H.make_record ["empty", H.make_record []]
| C.Kfields _ -> H.make_record ["empty", H.make_record []]
(* TODO - ... *))
| C.Hidden -> expr_aux sch (SchemaGraph.unique_next sch n)
View
109 libqmlcompil/dbGen/schema_private.ml
@@ -782,6 +782,58 @@ let db_declaration t name =
let decl = StringListMap.find [name] t in
(decl.ident, decl.options)
+let rec dots field ty =
+ match field with
+ | [] -> ty
+ | f::t ->
+ match ty with
+ | Q.TypeRecord (Q.TyRow (row, _var) as tyrow) ->
+ let ty =
+ try List.assoc f row with Not_found ->
+ failwith (BaseFormat.sprintf "'%s' is not found inside row {%a}"
+ f QmlPrint.pp#tyrow tyrow)
+ in dots t ty
+ | _ -> raise Not_found (* TODO error reporting *)
+
+let coerce_query_element ~context ty query =
+ let rec aux new_annots ty query =
+ let coerce wrap ty expr =
+ let e = QmlAstCons.UntypedExpr.coerce expr ty in
+ Q.QAnnot.expr e::new_annots, wrap e
+ in
+ let aux2 wrap ty (q1, q2) =
+ let new_annots, q1 = aux new_annots ty q1 in
+ let new_annots, q2 = aux new_annots ty q2 in
+ new_annots, wrap (q1, q2)
+ in
+ match query with
+ | Db.QEq expr -> coerce (fun e -> Db.QEq e) ty expr
+ | Db.QGt expr -> coerce (fun e -> Db.QGt e) ty expr
+ | Db.QLt expr -> coerce (fun e -> Db.QLt e) ty expr
+ | Db.QGte expr -> coerce (fun e -> Db.QGte e) ty expr
+ | Db.QLte expr -> coerce (fun e -> Db.QLte e) ty expr
+ | Db.QNe expr -> coerce (fun e -> Db.QNe e) ty expr
+ | Db.QIn expr ->
+ let ty = QmlAst.TypeName ([ty], Q.TypeIdent.of_string Opacapi.Types.list) in
+ coerce (fun e -> Db.QIn e) ty expr
+ | Db.QOr (q1, q2) -> aux2 (fun (q1, q2) -> Db.QOr (q1, q2)) ty (q1, q2)
+ | Db.QAnd (q1, q2) -> aux2 (fun (q1, q2) -> Db.QAnd (q1, q2)) ty (q1, q2)
+ | Db.QNot query ->
+ let new_annots, query = aux new_annots ty query in
+ new_annots, (Db.QNot query)
+ | Db.QMod _ when ty = Q.TypeConst Q.TyInt -> new_annots, query
+ | Db.QMod _ -> QmlError.error context "mod is avialable only on integers"
+ | Db.QFlds flds ->
+ let new_annots, flds =
+ List.fold_left_map
+ (fun acc (field, q) ->
+ let acc, q = aux acc (dots field ty) q in
+ acc, (field, q))
+ new_annots flds
+ in new_annots, Db.QFlds flds
+
+ in aux [] ty query
+
(** @return (new_annots_list, pppath) *)
let rec convert_dbpath ~context t node kind path0 path =
let context = QmlError.Context.merge2 context (V.label node).C.context in
@@ -865,6 +917,19 @@ let rec convert_dbpath ~context t node kind path0 path =
let new_annots, epath = convert_dbpath ~context t (SchemaGraph.unique_next t node) kind path0 path in
new_annots, Db.NewKey :: epath
+ | Db.Query query::[] ->
+ let new_annots, query =
+ let ty =
+ match SchemaGraphLib.type_of_node node with
+ | Q.TypeName ([setparam], name) when Q.TypeIdent.to_string name = "dbset" -> setparam
+ | _ -> SchemaGraphLib.type_of_key t node
+ in
+ coerce_query_element ~context ty query
+ in
+ new_annots, [Db.Query query]
+
+ | Db.Query _::_path -> QmlError.error context "sub path after query is not handler yet"
+
let get_virtual_path vpath epath =
let rec aux acc = function
| ((Db.Decl_fld f1)::q1, ((Db.FldKey f2) as e)::q2) when f1 = f2 ->
@@ -918,6 +983,18 @@ let rec find_exprpath_aux ?context t ?(node=SchemaGraphLib.get_root t) ?(kind=Db
QmlPrint.pp#path_elts epath0
in
find_exprpath_aux ~context t ~node:next ~kind ~epath0 vpath epath
+ | (Db.Query _q)::epath, C.Multi ->
+ let setty = node.C.ty in
+ (match setty with
+ | Q.TypeName ([_], name)
+ when Q.TypeIdent.to_string name = "dbset" ->
+ (match epath with
+ | [] -> ()
+ | _ -> OManager.error "You can't extend a virtual path");
+ let node, partial, tyread = node, true, setty in
+ node, `virtualset (tyread, tyread, partial, None)
+ | _ -> find_exprpath_aux ~context t ~node:(SchemaGraph.unique_next t node) ~kind ~epath0 vpath epath)
+
| (Db.ExprKey e)::epath, C.Multi ->
let setty = node.C.ty in
let uncoerce = match e with
@@ -986,14 +1063,20 @@ let preprocess_kind ~context kind ty virtual_ =
| `virtualset (r, _, _, _) -> r
| _ -> assert false
in
- let rec update ty u =
+ let coerce e ty = QmlAstCons.UntypedExpr.coerce e ty in
+ let coerce_list e ty =
+ match ty with
+ | Q.TypeName ([param], name) when Q.TypeIdent.to_string name = "list" ->
+ coerce e param
+ | _ -> assert false
+ in
+ let rec update (ty:QmlAst.ty) u =
let error fmt0 fmt =
QmlError.error context ("Can't update "^^fmt0^^" because "^^fmt)
in
match u with
- | Db.UExpr e ->
- Db.UExpr (QmlAstCons.UntypedExpr.coerce e ty)
- | Db.UFields fields ->
+ | Db.UExpr e -> Db.UExpr (coerce e ty)
+ | Db.UFlds fields ->
let rec dots field ty =
let rec aux field ty =
match field with
@@ -1009,12 +1092,26 @@ let preprocess_kind ~context kind ty virtual_ =
| _ -> error "tofo" "todo2"
in aux field ty
in
- Db.UFields (List.map (function (field, u) -> (field, update (dots field ty) u)) fields)
+ Db.UFlds
+ (List.map
+ (function (field, u) -> (field, update (dots field ty) u))
+ fields)
+ | Db.UAppend e -> Db.UAppend (coerce_list e ty)
+ | Db.UPrepend e -> Db.UPrepend (coerce_list e ty)
+ | Db.UAppendAll e -> Db.UAppendAll (coerce e ty)
+ | Db.UPrependAll e -> Db.UPrependAll (coerce e ty)
| Db.UIncr _ when (
- match ty with
+ match ty with (* TODO - unify! *)
| Q.TypeConst Q.TyInt -> true
| _ -> false
) -> u
+ | (Db.UPop | Db.UShift) when (
+ match ty with (* TODO - unify???! *)
+ | Q.TypeName ([_], name) when Q.TypeIdent.to_string name = "list" -> true
+ | _ -> false
+ ) -> u
+ | Db.UPop -> error "" "pop is not avialable on %a" QmlPrint.pp#ty ty
+ | Db.UShift -> error "" "shift is not avialable on %a" QmlPrint.pp#ty ty
| Db.UIncr _ -> error "" "incr is not avialable only on %a" QmlPrint.pp#ty ty
in Db.Update (update ty u)
View
137 libqmlcompil/qmlAst.ml
@@ -128,22 +128,36 @@ end
module Db =
struct
+ type 'expr fields = (string list * 'expr) list
+
type 'expr query =
- | QGt of 'expr
- | QLt of 'expr
- | QGte of 'expr
- | QLte of 'expr
- | QNe of 'expr
- | QMod of int
- | QIn of 'expr
- | QOr of 'expr
- | QAnd of 'expr
- | QNot of 'expr query
+ | QEq of 'expr
+ | QGt of 'expr
+ | QLt of 'expr
+ | QGte of 'expr
+ | QLte of 'expr
+ | QNe of 'expr
+ | QMod of int
+ | QIn of 'expr
+ | QOr of 'expr query * 'expr query
+ | QAnd of 'expr query * 'expr query
+ | QNot of 'expr query
+ | QFlds of 'expr query fields
type 'expr update =
- | UFields of (string list * 'expr update) list
+ (* Record updating*)
+ | UFlds of 'expr update fields
+
+ (* Simple updating*)
| UExpr of 'expr
- | UIncr of int
+ | UIncr of int (* TODO : expr*)
+
+ (* List updating *)
+ | UAppend of 'expr
+ | UAppendAll of 'expr
+ | UPrepend of 'expr
+ | UPrependAll of 'expr
+ | UPop | UShift
(** The kind of a path, ie the type of access it is *)
type 'expr kind =
@@ -228,21 +242,47 @@ struct
| Db_Constraint of path_decl * 'expr db_constraint
| Db_Virtual of path_decl * 'expr
- let rec pp_field fmt = function
- | t0::((_::_) as q) -> Format.fprintf fmt "%s.%a" t0 pp_field q
- | t0::[] -> Format.fprintf fmt "%s" t0
- | [] -> Format.fprintf fmt ""
+ let pp = BaseFormat.fprintf
- let update_to_string = function
- | UExpr _ -> "uexpr"
- | UFields fields ->
- Printf.sprintf "fields %s;"
- (List.to_string (fun (f,_) -> List.to_string (fun x -> x) f) fields)
- | UIncr i -> Printf.sprintf "+=%i" i
-
- let path_kind_to_string = function
- | Default -> "" | Option -> "?" | Valpath -> "!" | Ref -> "@"
- | Update u -> Printf.sprintf "<- %s" (update_to_string u)
+ let rec pp_field fmt = function
+ | t0::((_::_) as q) -> pp fmt "%s.%a" t0 pp_field q
+ | t0::[] -> pp fmt "%s" t0
+ | [] -> pp fmt ""
+
+ let rec pp_update pp_expr fmt = function
+ | UExpr e -> pp fmt ": %a" pp_expr e
+ | UFlds fields ->
+ pp fmt "(";
+ List.iter
+ (function (f, u) ->
+ pp fmt "%a %a" pp_field f (pp_update pp_expr) u) fields;
+ pp fmt ")";
+ | UIncr i -> pp fmt "+=%i" i
+ | UAppend expr -> pp fmt "<+ %a" pp_expr expr
+ | UAppendAll expr -> pp fmt "<++ %a" pp_expr expr
+ | UPrepend expr -> pp fmt "+> %a" pp_expr expr
+ | UPrependAll expr -> pp fmt "++> %a" pp_expr expr
+ | UPop -> pp fmt "pop"
+ | UShift -> pp fmt "shift"
+
+ let pp_path_elt pp_expr f =
+ function
+ | FldKey (s) -> pp f "/%s" s
+ | ExprKey e -> pp f "[@[<hv>%a@]]" pp_expr e
+ | NewKey -> pp f "[?]"
+ | Query _ -> pp f "query TODO"
+
+ let pp_path pp_expr f (el, knd) =
+ let pp_el fmt () = pp fmt "%a" (BaseFormat.pp_list "" (pp_path_elt pp_expr)) el in
+ match knd with
+ | Update u -> pp f "%a <- %a" pp_el () (pp_update pp_expr) u
+ | _ ->
+ pp f "%s%a" (
+ match knd with
+ | Default -> "" | Option -> "?"
+ | Valpath -> "!" | Ref -> "@"
+ | Update _ -> assert false
+ ) pp_el ()
let engine_to_string opt =
match opt with
@@ -323,11 +363,16 @@ struct
TU.wrap (fun (p,e) -> Db_Virtual (p,e)) (TU.sub_2 TU.sub_ignore sub_e (p,e))
let rec sub_db_update sub_e sub_ty = function
- | UExpr expr ->
- TU.wrap (fun e -> UExpr e) (sub_e expr)
- | UIncr _ as e -> TU.sub_ignore e
- | UFields fields ->
- TU.wrap (fun fields -> UFields fields) (TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_update sub_e sub_ty)) fields)
+ | (UPop | UShift | UIncr _) as e -> TU.sub_ignore e
+ | UExpr expr -> TU.wrap (fun e -> UExpr e) (sub_e expr)
+ | UAppend expr -> TU.wrap (fun e -> UAppend e) (sub_e expr)
+ | UAppendAll expr -> TU.wrap (fun e -> UAppendAll e) (sub_e expr)
+ | UPrepend expr -> TU.wrap (fun e -> UPrepend e) (sub_e expr)
+ | UPrependAll expr -> TU.wrap (fun e -> UPrependAll e) (sub_e expr)
+ | UFlds fields ->
+ TU.wrap
+ (fun fields -> UFlds fields)
+ (TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_update sub_e sub_ty)) fields)
let sub_db_kind sub_e sub_ty = function
| Default
@@ -337,6 +382,36 @@ struct
| Update update ->
TU.wrap (fun u -> Update u) (sub_db_update sub_e sub_ty update)
+ let rec sub_db_query sub_e sub_ty = function
+ | QMod _ as e -> TU.sub_ignore e
+ | QEq e -> TU.wrap (fun e -> QEq e) (sub_e e)
+ | QGt e -> TU.wrap (fun e -> QGt e) (sub_e e)
+ | QLt e -> TU.wrap (fun e -> QLt e) (sub_e e)
+ | QGte e -> TU.wrap (fun e -> QGte e) (sub_e e)
+ | QLte e -> TU.wrap (fun e -> QLte e) (sub_e e)
+ | QNe e -> TU.wrap (fun e -> QNe e) (sub_e e)
+ | QIn e -> TU.wrap (fun e -> QIn e) (sub_e e)
+ | QOr (q1, q2) ->
+ TU.wrap
+ (fun (q1,q2) -> QOr (q1,q2))
+ (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query sub_e sub_ty) (q1, q2))
+ | QAnd (q1, q2) ->
+ TU.wrap
+ (fun (q1,q2) -> QAnd (q1,q2))
+ (TU.sub_2 (sub_db_query sub_e sub_ty) (sub_db_query sub_e sub_ty) (q1, q2))
+ | QNot q -> TU.wrap (fun e -> QNot e) (sub_db_query sub_e sub_ty q)
+
+ | QFlds flds ->
+ TU.wrap
+ (fun fields -> QFlds fields)
+ (TU.sub_list (TU.sub_2 TU.sub_ignore (sub_db_query sub_e sub_ty)) flds)
+
+ let sub_path_elt sub_e sub_ty = function
+ | FldKey _
+ | NewKey as v -> TU.sub_ignore v
+ | ExprKey e -> TU.wrap (fun x -> ExprKey x) (sub_e e)
+ | Query query -> TU.wrap (fun q -> Query q) (sub_db_query sub_e sub_ty query)
+
let foldmap_expr f acc dbdef =
let cons, subs = sub_db_def TU.sub_current TU.sub_ignore dbdef in
let acc, subs = List.fold_left_map f acc subs in
View
32 libqmlcompil/qmlAstWalk.ml
@@ -507,6 +507,7 @@ struct
module S2 =
struct
type 'a t = QmlAst.expr constraint 'a = _ * _ * _
+
let foldmap tra acc input_e =
match input_e with
| Q.Directive (label, `hybrid_value, [e_client;e_server], z) ->
@@ -618,12 +619,29 @@ struct
| Q.Db.Update u ->
let rec update acc u =
match u with
+ | QmlAst.Db.UPop | QmlAst.Db.UShift
+ | QmlAst.Db.UIncr _ -> acc, u
+ | QmlAst.Db.UAppend e ->
+ let acc, e' = tra acc e in
+ acc,
+ if e == e' then u else QmlAst.Db.UAppend e'
+ | QmlAst.Db.UPrepend e ->
+ let acc, e' = tra acc e in
+ acc,
+ if e == e' then u else QmlAst.Db.UPrepend e'
+ | QmlAst.Db.UAppendAll e ->
+ let acc, e' = tra acc e in
+ acc,
+ if e == e' then u else QmlAst.Db.UAppendAll e'
+ | QmlAst.Db.UPrependAll e ->
+ let acc, e' = tra acc e in
+ acc,
+ if e == e' then u else QmlAst.Db.UPrependAll e'
| QmlAst.Db.UExpr e ->
let acc, e' = tra acc e in
acc,
if e == e' then u else QmlAst.Db.UExpr e'
- | QmlAst.Db.UIncr _i -> acc, u
- | QmlAst.Db.UFields fields ->
+ | QmlAst.Db.UFlds fields ->
let acc, fields' =
List.fold_left_map_stable
(fun acc ((f,u) as bnd) ->
@@ -632,7 +650,7 @@ struct
if u == u' then bnd else (f, u')
) acc fields in
acc,
- if fields == fields' then u else QmlAst.Db.UFields fields'
+ if fields == fields' then u else QmlAst.Db.UFlds fields'
in
let acc, u' = update acc u in
acc,
@@ -684,9 +702,13 @@ struct
| Q.Db.Update u ->
let rec update acc u =
match u with
+ | QmlAst.Db.UPop | QmlAst.Db.UShift | QmlAst.Db.UIncr _ -> acc
+ | QmlAst.Db.UAppend e
+ | QmlAst.Db.UPrepend e
+ | QmlAst.Db.UAppendAll e
+ | QmlAst.Db.UPrependAll e
| QmlAst.Db.UExpr e -> tra acc e
- | QmlAst.Db.UIncr _i -> acc
- | QmlAst.Db.UFields fields ->
+ | QmlAst.Db.UFlds fields ->
List.fold_left
(fun acc (_,u) -> update acc u)
acc fields
View
85 libqmlcompil/qmlDbGen.ml
@@ -69,28 +69,30 @@ module Schema = struct
package : ObjectFiles.package_name;
}
+ type query = QmlAst.expr QmlAst.Db.query
+
+ type set_kind =
+ | Map of QmlAst.ty * QmlAst.ty
+ | DbSet of QmlAst.ty
+
+ type node_kind =
+ | Compose of (string * string list) list
+ | Plain
+ | Partial of string list * string list
+ | SetAccess of set_kind * string list * (bool * query) option (*bool == unique*)
+
type node = {
ty : QmlAst.ty;
kind : node_kind;
database : database;
default : QmlAst.expr;
}
- and node_kind =
- | Compose of (string * string list) list
- | Plain
- | Partial of string list * string list
- | SetAccess of string list * bool * query
-
- and query =
- | Empty
- | Expr of QmlAst.expr
-
- let pp_query fmt e =
- match e with
- | Empty -> Format.fprintf fmt "empty"
- | Expr e -> Format.fprintf fmt "{%a}" QmlPrint.pp#expr e
+ let pp_query fmt _e = Format.fprintf fmt "todo query"
+ let pp_set_kind fmt = function
+ | DbSet ty -> Format.fprintf fmt "dbset(%a)" QmlPrint.pp#ty ty
+ | Map (kt, vt) -> Format.fprintf fmt "map(%a, %a)" QmlPrint.pp#ty kt QmlPrint.pp#ty vt
let pp_kind fmt kind =
let pp_path fmt p =
@@ -101,11 +103,11 @@ module Schema = struct
| Plain -> Format.fprintf fmt "plain"
| Partial (p0, p1) -> Format.fprintf fmt "partial (%a, %a)" pp_path p0 pp_path p1
| Compose _ -> Format.fprintf fmt "cmp (...)"
- | SetAccess (path, full, query) ->
- Format.fprintf fmt "@[<hov>%s access to %a with %a@]"
- (if full then "full" else "partial")
+ | SetAccess (sk, path, query) ->
+ Format.fprintf fmt "@[<hov>access to %a : %a with %a@]"
pp_path path
- pp_query query
+ pp_set_kind sk
+ (Option.pp_none pp_query) query
let pp_node fmt node =
Format.fprintf fmt "{@[<hov>type : %a; kind : %a; ...@]}"
@@ -142,9 +144,9 @@ module Schema = struct
})
let to_dot t chan =
StringListMap.iter
- (fun key db_def ->
- output_string chan (String.concat "/" key);
- output_char chan '\n';
+ (fun _key db_def ->
+ (* output_string chan (String.concat "/" key); *)
+ (* output_char chan '\n'; *)
Schema_io.to_dot db_def.Sch.schema chan)
t
@@ -191,6 +193,7 @@ module Schema = struct
| (DbAst.FldKey s0, C.Field (s1, _)) when s0 = s1 -> true
| (DbAst.FldKey _s0, _) -> false
| (DbAst.ExprKey _, C.Multi_edge _) -> true
+ | (DbAst.Query _, C.Multi_edge _) -> true
| _ -> assert false (* TODO *)
in
let v = match (Graph.V.label node).C.nlabel with
@@ -225,18 +228,33 @@ module Schema = struct
in
let declaration = StringListMap.find [dbname] schema in
let database = get_database schema dbname in
+ let llschema = declaration.Sch.schema in
let f (node, kind, path) fragment =
- let next = next declaration.Sch.schema node fragment in
+ let next = next llschema node fragment in
+ let get_setkind schema node =
+ match Graph.succ_e schema node with
+ | [edge] -> begin match (Graph.E.label edge).C.label with
+ | C.Multi_edge C.Kint ->
+ Map (QmlAst.TypeConst QmlAst.TyInt, next.C.ty)
+ | C.Multi_edge C.Kstring ->
+ Map (QmlAst.TypeConst QmlAst.TyString, next.C.ty)
+ | C.Multi_edge (C.Kfields _) -> DbSet next.C.ty
+ | _ -> assert false
+ end
+ | [] -> raise Not_found
+ | _ -> raise Not_found
+ in
match fragment with
| DbAst.ExprKey expr ->
- let kind = SetAccess (path, false, Expr expr) in
+ let setkind = get_setkind llschema node in
+ let kind = SetAccess (setkind, path, Some (true, DbAst.QEq expr)) in
(next, kind, path)
| DbAst.FldKey key ->
let kind =
let nlabel = Graph.V.label next in
match nlabel.C.nlabel with
- | C.Multi -> SetAccess (key::path, true, Empty)
+ | C.Multi -> SetAccess (get_setkind llschema next, key::path, None)
| _ -> match kind, nlabel.C.plain with
| Compose _, true -> Plain
| Partial (path, part), false -> Partial (path, key::part)
@@ -247,10 +265,19 @@ module Schema = struct
| _, _ -> assert false
in let path = key::path
in (next, kind, path)
+ | DbAst.Query query ->
+ begin match kind with
+ | SetAccess (_k, path, None) ->
+ let kind = SetAccess (get_setkind llschema node, path, Some (false, query)) in
+ (next, kind, path)
+ | SetAccess (_, _path, Some _) -> assert false
+ | _ -> assert false
+ end
| _ -> assert false
+
in
let (node, kind, _path) =
- List.fold_left f (get_root declaration.Sch.schema, Compose [], []) path in
+ List.fold_left f (get_root llschema, Compose [], []) path in
let kind =
match kind with
| Compose _ -> (
@@ -264,20 +291,20 @@ module Schema = struct
(fun edge ->
let sname = SchemaGraphLib.fieldname_of_edge edge
in sname, dbname::path @ [sname])
- (Graph.succ_e declaration.Sch.schema node)
+ (Graph.succ_e llschema node)
)
| _ -> assert false
)
| Partial (path, part) ->
Partial (List.rev path, List.rev part)
- | SetAccess (path, full, query) ->
- SetAccess (List.rev path, full, query)
+ | SetAccess (k, path, query) ->
+ SetAccess (k, List.rev path, query)
| Plain -> Plain
in
let (annotmap, default) =
DbGen_private.Default.expr
annotmap
- declaration.Sch.schema
+ llschema
node
in
annotmap,
View
28 libqmlcompil/qmlDbGen.mli
@@ -53,29 +53,25 @@ module Schema: sig
package : ObjectFiles.package_name;
}
+ type query = QmlAst.expr QmlAst.Db.query
+
+ type set_kind =
+ | Map of QmlAst.ty * QmlAst.ty
+ | DbSet of QmlAst.ty
+
+ type node_kind =
+ | Compose of (string * string list) list
+ | Plain
+ | Partial of string list * string list
+ | SetAccess of set_kind * string list * (bool * query) option (*bool == unique*)
+
type node = {
ty : QmlAst.ty;
kind : node_kind;
database : database;
default : QmlAst.expr;
}
- and node_kind =
- | Compose of (string * string list) list
-
- | Plain
-
- (** Indicates that is a sub node of a Plain node. (plain node,
- path of the plain node, sub path from plain node) *)
- | Partial of string list * string list
-
- | SetAccess of string list * bool * query
-
- (** *)
- and query =
- | Empty
- | Expr of QmlAst.expr
-
(** Maps the idents of the different database schemas and their respective
options in a multi-schema *)
View
3 libqmlcompil/qmlDependencies.ml
@@ -263,7 +263,8 @@ let get_expr_dep_context ?filter e =
match List.hd dbelt with
| Q.Db.FldKey s -> Option.if_none filter (add_root s acc) acc
| Q.Db.NewKey
- | Q.Db.ExprKey _ ->
+ | Q.Db.ExprKey _
+ | Q.Db.Query _ ->
(* not possible, see the parser *)
assert false
)
View
12 libqmlcompil/qmlPrint.ml
@@ -325,7 +325,16 @@ object (self)
| c -> Format.pp_print_string f (Q.Const.string_of_expr c)
method path f (el, knd) =
- pp f "%s%a" (Q.Db.path_kind_to_string knd) (pp_list "" self#path_elt) el
+ let pp_el fmt () = Format.fprintf fmt "%a" (pp_list "" self#path_elt) el in
+ match knd with
+ | Q.Db.Update u -> pp f "%a <- %a" pp_el () (QmlAst.Db.pp_update self#expr) u
+ | _ ->
+ pp f "%s%a" (
+ match knd with
+ | Q.Db.Default -> "" | Q.Db.Option -> "?"
+ | Q.Db.Valpath -> "!" | Q.Db.Ref -> "@"
+ | Q.Db.Update _ -> assert false
+ ) pp_el ()
method path_elts f el =
pp f "%a" (pp_list "" self#path_elt) el
@@ -440,6 +449,7 @@ object (self)
| Db.FldKey (s) -> pp f "/%s" s
| Db.ExprKey e -> pp f "[@[<hv>%a@]]" self#reset#expr e
| Db.NewKey -> pp f "[?]"
+ | Db.Query _ -> pp f "query TODO"
(*---------------------*)
(*---- code printer ---*)
View
29 libqmlcompil/typer_w/w_Infer.ml
@@ -1021,20 +1021,45 @@ and infer_db_path ~bypass_typer typing_env ~surrounding_path_expr keys kind =
let (_e_ty, e_annotmap) =
infer_expr_type ~bypass_typer typing_env e in
QmlAnnotMap.merge annotmap_accu e_annotmap
+ | QmlAst.Db.Query q ->
+ let rec aux annotmap_accu = function
+ | QmlAst.Db.QMod _ -> annotmap_accu
+ | QmlAst.Db.QEq e
+ | QmlAst.Db.QGt e
+ | QmlAst.Db.QLt e
+ | QmlAst.Db.QGte e
+ | QmlAst.Db.QLte e
+ | QmlAst.Db.QNe e
+ | QmlAst.Db.QIn e ->
+ let (_e_ty, e_annotmap) =
+ infer_expr_type ~bypass_typer typing_env e in
+ QmlAnnotMap.merge annotmap_accu e_annotmap
+ | QmlAst.Db.QOr (q1, q2)
+ | QmlAst.Db.QAnd (q1, q2) ->
+ aux (aux annotmap_accu q1) q2
+ | QmlAst.Db.QNot q -> aux annotmap_accu q
+ | QmlAst.Db.QFlds flds ->
+ List.fold_left (fun a (_, q) -> aux a q) annotmap_accu flds
+ in aux annotmap_accu q
| _ -> annotmap_accu)
keys W_AnnotMap.empty_annotmap in
(* Typecheck update ast and recover the updated annotation map. *)
let annotmap' = match kind with
| QmlAst.Db.Default | QmlAst.Db.Option | QmlAst.Db.Valpath | QmlAst.Db.Ref -> annotmap'
| QmlAst.Db.Update u ->
let rec aux annotmap_accu = function
+ | QmlAst.Db.UPop | QmlAst.Db.UShift
+ | QmlAst.Db.UIncr _ -> annotmap_accu
+ | QmlAst.Db.UAppend e
+ | QmlAst.Db.UPrepend e
+ | QmlAst.Db.UAppendAll e
+ | QmlAst.Db.UPrependAll e
| QmlAst.Db.UExpr e ->
(* [TODO] check [_e_ty] against something somehow ? *)
let (_e_ty, e_annotmap) =
infer_expr_type ~bypass_typer typing_env e in
QmlAnnotMap.merge annotmap_accu e_annotmap
- | QmlAst.Db.UIncr _i -> annotmap_accu
- | QmlAst.Db.UFields fields ->
+ | QmlAst.Db.UFlds fields ->
List.fold_left (fun a (_,u) -> aux a u) annotmap_accu fields
in aux annotmap' u
in

0 comments on commit c197c0f

Please sign in to comment.
Something went wrong with that request. Please try again.