Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[feature] compiler, database: Just naive update of libqmlcompil (for …

…path selection)
  • Loading branch information...
commit df80d98c09a1e3cfa46b4b90edfce7134e906004 1 parent e9e550e
@BourgerieQuentin BourgerieQuentin authored
View
9 libqmlcompil/qmlAlphaConv.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -277,7 +277,12 @@ let rec expr t e =
| Q.ExtendRecord (label, f, e, n) -> Q.ExtendRecord (label, f, expr t e, expr t n)
| (Q.Bypass _) as by -> by
| Q.Coerce (label, e, ty) -> Q.Coerce (label, expr t e, ty)
- | Q.Path (label, p,h) -> Q.Path (label, List.map (function Q.Db.ExprKey e -> Q.Db.ExprKey (expr t e) | k -> k) p, h)
+ | Q.Path (_label, _p, _h, _s) as path ->
+ QmlAstWalk.Expr.traverse_map
+ (fun tra -> function
+ | Q.Path (_, _, _, _) as e -> tra e
+ | e -> expr t e)
+ path
| Q.Directive (_, `backend_ident _,_,_) as e ->
(* not going inside `backend_ident, because it does contain
View
10 libqmlcompil/qmlDbGen.ml
@@ -69,7 +69,13 @@ module Schema = struct
default : QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
}
- let pp_query fmt _e = Format.fprintf fmt "todo query"
+ let pp_query fmt = function
+ | None -> ()
+ | Some (u, (q, o)) ->
+ Format.fprintf fmt "[%a%a]/* uniq : %b */"
+ (QmlAst.Db.pp_query QmlPrint.pp#expr) q
+ (QmlAst.Db.pp_options QmlPrint.pp#expr) o
+ u
let pp_set_kind fmt = function
| DbSet ty -> Format.fprintf fmt "dbset(%a)" QmlPrint.pp#ty ty
@@ -90,7 +96,7 @@ module Schema = struct
Format.fprintf fmt "@[<hov>access to %a : %a with %a@]"
pp_path path
pp_set_kind sk
- (Option.pp_none pp_query) query
+ pp_query query
let pp_node fmt node =
Format.fprintf fmt "{@[<hov>type : %a; kind : %a; ...@]}"
View
4 libqmlcompil/qmlDependencies.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -257,7 +257,7 @@ let get_expr_dep_context ?filter e =
(*{ acc with fields_groups = List.fold (fun groups (p,_)-> add_group (get_fields_pat p) groups) acc.fields_groups _pel }*)
(*let _p = List.map pel in*)
(* FIXME: ??? don't know what to do *)
- | Q.Path (_, dbelt, _)-> (
+ | Q.Path (_, dbelt, _, _)-> (
let acc = Option.if_none filter (add_database acc) acc in
(* taking the first elt of the path *)
match List.hd dbelt with
View
4 libqmlcompil/qmlEffects.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -356,7 +356,7 @@ struct
rewrite_arrow level its_effect qty
| Q.Coerce (_, e, _) ->
infer bp env effect (level+1) e
- | Q.Path (_, el, _) ->
+ | Q.Path (_, el, _, _) ->
List.iter (function
| Q.Db.ExprKey e -> ignore (infer bp env effect (level+1) e)
| _ -> ()) el;
View
14 libqmlcompil/qmlPrint.ml
@@ -324,17 +324,7 @@ object (self)
| Q.String s -> Format.fprintf f "\"%s\"" (escaped_string s)
| c -> Format.pp_print_string f (Q.Const.string_of_expr c)
- method path f (el, knd) =
- 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 f (el, knd, select) = QmlAst.Db.pp_path self#expr f (el, knd, select)
method path_elts f el =
pp f "%a" (pp_list "" self#path_elt) el
@@ -369,7 +359,7 @@ object (self)
pp f "@[<2>{%s = %a} ::@ %a@]" s self#expr e1 self#expr e2
| Q.Bypass (_, s) -> Format.pp_print_string f ("%%" ^ (BslKey.to_string s) ^ "%%")
| Q.Coerce (_, e,ty) -> pp f "%a : %a" self#under_coerce#expr e self#ty ty
- | Q.Path (_, el, knd) -> self#path f (el, knd)
+ | Q.Path (_, el, knd, select) -> self#path f (el, knd, select)
| Q.Directive (_, `module_, [e], _) -> pp f "{%a}" self#reset#expr e
| Q.Directive (_, dir, exprs, tys) -> self#directive f dir exprs tys
method bind_field fmt (f, d) = pp fmt "%s = %a" f self#under_record#expr d
View
26 opa/pass_MongoAccessGeneration.ml
@@ -1,3 +1,21 @@
+(*
+ Copyright © 2011, 2012 MLstate
+
+ This file is part of OPA.
+
+ OPA is free software: you can redistribute it and/or modify it under the
+ terms of the GNU Affero General Public License, version 3, as published by
+ the Free Software Foundation.
+
+ OPA is distributed in the hope that it will be useful, but WITHOUT ANY
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+ FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
+ more details.
+
+ You should have received a copy of the GNU Affero General Public License
+ along with OPA. If not, see <http://www.gnu.org/licenses/>.
+*)
+
(* shorthands *)
module Q = QmlAst
module C = QmlAstCons.TypedExpr
@@ -672,7 +690,7 @@ module Generator = struct
(annotmap, set)
- let path ~context gamma annotmap schema (label, dbpath, kind) =
+ let path ~context gamma annotmap schema (label, dbpath, kind, select) =
let node = get_node ~context schema dbpath in
match node.DbSchema.database.DbSchema.options.DbAst.backend with
| `mongo -> (
@@ -697,7 +715,7 @@ module Generator = struct
C.apply gamma annotmap p2p [mongopath]
| _ -> annotmap, mongopath
)
- | `db3 -> annotmap, Q.Path (label, dbpath, kind)
+ | `db3 -> annotmap, Q.Path (label, dbpath, kind, select)
let indexes gamma annotmap _schema node rpath lidx =
let (annotmap, database) =
@@ -770,10 +788,10 @@ let clean_code gamma annotmap schema code =
let process_path gamma annotmap schema code =
let fmap tra annotmap = function
- | Q.Path (label, path, kind) as expr ->
+ | Q.Path (label, path, kind, select) as expr ->
let context = QmlError.Context.annoted_expr annotmap expr in
let annotmap, result =
- Generator.path ~context gamma annotmap schema (label, path, kind) in
+ Generator.path ~context gamma annotmap schema (label, path, kind, select) in
tra annotmap result
| e -> tra annotmap e
in
View
4 qmlcps/qmlCpsRewriter.ml
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -885,7 +885,7 @@ let il_of_qml ?(can_skip_toplvl=false) (env:env) (private_env:private_env) (expr
| Q.Coerce (_, e, _) -> aux_can_skip ~can_skip_lambda e context
- | Q.Path (_, _, _) ->
+ | Q.Path (_, _, _, _) ->
failwith "Internal error: At this stage, all first-class paths should have been compiled."
(* Concurrency-specific directive, and cps specific *)
Please sign in to comment.
Something went wrong with that request. Please try again.