Permalink
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...
BourgerieQuentin committed Jan 24, 2012
1 parent 6ada700 commit c197c0f7d98f97d25d0fcabdd755662b7363b2ba
@@ -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)
@@ -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
@@ -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
@@ -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
Oops, something went wrong.

0 comments on commit c197c0f

Please sign in to comment.