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

opalang/opaPrint.ml

@@ -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 _,_)

opalang/opaToQml.ml

@@ -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)
 

opalang/opaWalk.ml

@@ -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,

opalang/surfaceAst.ml

@@ -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
 
       (**

opalang/surfaceAstHelper.ml

@@ -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 *)

opalang/surfaceAstTraversal.ml

@@ -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

passes/surfaceAstDependencies.ml

@@ -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

passes/surfaceAstRenaming.ml

@@ -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