Permalink
Browse files

[feature] compiler, database: Added path selection to surface ast

  • Loading branch information...
1 parent df80d98 commit c1a67b59f490100483ab78873fce0a71a22b6695 @BourgerieQuentin BourgerieQuentin committed Apr 11, 2012
View
@@ -751,7 +751,7 @@ module Classic = struct
pp f "@[<1>{%a with@ %a}@]" self#expr e (list ";@ " self#record_binding) r
| Dot (e,s) -> pp f "%a.%a" self#apply_expr e self#field s
| Bypass s -> pp f "%%%%%s%%%%" (BslKey.to_string s)
- | DBPath (elt,kind) -> pp f "%a" (QmlAst.Db.pp_path self#expr) (List.map fst (fst elt), kind)
+ | DBPath (elt,kind,select) -> pp f "%a" (QmlAst.Db.pp_path self#expr) (List.map fst (fst elt), kind, select)
| Directive d -> self#directive f d
method private apply_expr : 'dir. ('ident,[< all_directives ] as 'dir) expr pprinter = fun f -> function
| (Ident _,_)
@@ -1329,8 +1329,8 @@ module Js = struct
pp f "@[<1>{%a with@ %a}@]" self#expr e (list ",@ " self#record_binding) r
| Dot (e,s) -> pp f "%a.%a" self#apply_expr e self#field s
| Bypass s -> pp f "%%%%%s%%%%" (BslKey.to_string s)
- | DBPath (elt,kind) ->
- QmlAst.Db.pp_path self#expr f (List.map fst (fst elt), kind)
+ | DBPath (elt,kind, select) ->
+ QmlAst.Db.pp_path self#expr f (List.map fst (fst elt), kind, select)
| Directive d -> self#directive f d
method private apply_expr : 'dir. ('ident,[< all_directives ] as 'dir) expr pprinter = fun f -> function
| (Ident _,_)
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -448,9 +448,9 @@ struct
(* ********************************************************************** *)
and aux (x, opa_annot) =
match x with
- | SA.DBPath (path, access_kind) ->
+ | SA.DBPath (path, k, s) ->
let path = List.map (fun (elt, _) -> db_path elt) (fst path) in
- QA.Path ((make_label_from_opa_annot opa_annot), path, kind (access_kind))
+ QA.Path ((make_label_from_opa_annot opa_annot), path, kind k, select s)
| SA.Apply (e, r) ->
let e = aux e in
let args = List.map (fun (_, e') -> aux e') (fst r) in
@@ -519,6 +519,15 @@ struct
| QA.Db.Valpath -> QA.Db.Valpath
| QA.Db.Ref -> QA.Db.Ref
+ and select s =
+ let rebuild, exprs =
+ QmlAst.Db.sub_db_select
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ s in
+ let exprs' = List.map expr exprs in
+ rebuild exprs'
+
and expr_of_record e =
expr (SA.Record ((Parser_utils.encode_tuple [e])), Parser_utils.nlabel e)
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -241,7 +241,7 @@ struct
acc,
if e == e' then orig_e else
(Dot (e',s),lab)
- | DBPath (dbelt,kind) ->
+ | DBPath (dbelt,kind,select) ->
let acc, dbelt' =
foldmap_1_stable
(fun acc node ->
@@ -277,9 +277,18 @@ struct
let acc, exprs' = List.fold_left_map_stable tra acc exprs in
acc, rebuild exprs'
in
+ let acc, select' =
+ let rebuild, exprs =
+ QmlAst.Db.sub_db_select
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ select in
+ let acc, exprs' = List.fold_left_map_stable tra acc exprs in
+ acc, rebuild exprs'
+ in
acc,
- if dbelt == dbelt' && kind == kind' then orig_e else
- (DBPath (dbelt',kind'),lab)
+ if dbelt == dbelt' && kind == kind' && select == select' then orig_e else
+ (DBPath (dbelt',kind', select'),lab)
| Directive (variant,el,t) ->
let acc, el' = List.fold_left_map_stable tra acc el in
acc,
View
@@ -115,7 +115,10 @@ and ('ident, 'dir) expr_node =
| Dot of ('ident, 'dir) expr * string
| Bypass of BslKey.t (**A primitive, handled through the Bypass Standard Library*)
- | DBPath of ('ident, 'dir) dbelt * ('ident, 'dir) expr QmlAst.Db.kind
+ | DBPath of ('ident, 'dir) dbelt
+ * ('ident, 'dir) expr QmlAst.Db.kind
+ * ('ident, 'dir) expr QmlAst.Db.select
+
| Directive of ('ident, 'dir) directive
(**
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -47,7 +47,7 @@ let record r = Record r
let extendrecord (r,e) = ExtendRecord (r,e)
let dot (e,s) = Dot (e,s)
let bypass b = Bypass b
-let dbpath (a,b) = DBPath(a,b)
+let dbpath (a,b,c) = DBPath(a,b,c)
let directive (a,el,t) = Directive (a,el,t)
(* functions wrapping code_elt constructors *)
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -139,7 +139,7 @@ struct
| ExtendRecord (r,e) -> wrap extendrecord (sub_2 sub_record_node sub_e (r,e))
| Dot (e,s) -> wrap dot (sub_2 sub_e sub_ignore (e,s))
| Bypass b -> wrap bypass (sub_ignore b)
- | DBPath (a,b) -> wrap dbpath (sub_2 (unannot (sub_list (unannot sub_db_elt))) (QmlAst.Db.sub_db_kind sub_e sub_ty) (a,b))
+ | DBPath (a,b,c) -> wrap dbpath (sub_3 (unannot (sub_list (unannot sub_db_elt))) (QmlAst.Db.sub_db_kind sub_e sub_ty) (QmlAst.Db.sub_db_select sub_e sub_ty) (a,b,c))
| _ -> assert false
let sub_expr_node' fd = function
| Ident _ as e -> sub_ignore e
@@ -224,7 +224,7 @@ let get_expr_dep_context ?filter e =
| None ->
List.fold_left (fun acc (p,_) -> get_pat_dep_context acc p) acc pel
| Some _ -> acc)
- | DBPath (dbelt, _) ->
+ | DBPath (dbelt, _, _) ->
let acc = Option.if_none filter (add_database acc) acc in
(* taking the first elt of the path *)
( match (fst (List.hd (fst dbelt))) with
@@ -1253,10 +1253,11 @@ and f_expr_node all_env hierar label : (string, renaming_directive) expr_node ->
let f_env, r = f_record_node ~kind:`record all_env hierar r in
let f_env, e = f_expr {all_env with f = f_env} hierar e in
f_env, ExtendRecord (r, e)
- | DBPath (dbelt, d) ->
+ | DBPath (dbelt, d, s) ->
let f_env, dbelt = f_dbelt all_env hierar dbelt in
let f_env, d = f_kind {all_env with f = f_env} hierar d in
- f_env, DBPath (dbelt, d)
+ let f_env, s = f_select {all_env with f = f_env} hierar s in
+ f_env, DBPath (dbelt, d, s)
| Directive (`open_, l, _) ->
( match l with
| [e1;e2] ->
@@ -1293,6 +1294,18 @@ and f_kind all_env hierar kind =
let all_env, exprs' = List.fold_left_map f_expr all_env exprs in
all_env.f, rebuild exprs'
+and f_select all_env hierar select =
+ let rebuild, exprs =
+ QmlAst.Db.sub_db_select
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ select in
+ let f_expr all_env expr =
+ let (f, expr) = f_expr all_env hierar expr in
+ {all_env with f}, expr
+ in
+ let all_env, exprs' = List.fold_left_map f_expr all_env exprs in
+ all_env.f, rebuild exprs'
and update_all_env_with str ident e all_env =
match tree_option_of_expr str e with

0 comments on commit c1a67b5

Please sign in to comment.