Permalink
Browse files

[feature] compiler, database: Default values generator take care of s…

…election
  • Loading branch information...
BourgerieQuentin committed Apr 11, 2012
1 parent e87a068 commit 1aa37e7a55a4b7908a48c069dadfc0d5545ea430
Showing with 69 additions and 10 deletions.
  1. +21 −6 libqmlcompil/dbGen/dbGen_private.ml
  2. +41 −3 libqmlcompil/qmlDbGen.ml
  3. +7 −1 libqmlcompil/qmlDbGen.mli
@@ -85,10 +85,10 @@ let (@:) a b = H.(@:) a b
module Default = struct
- let rec expr_aux sch n =
- H.copy_expr (H.newexpr_annot (expr_for_def sch n) (SchemaGraphLib.type_of_node n))
+ let rec expr_aux ?select sch n =
+ H.copy_expr (H.newexpr_annot (expr_for_def ?select sch n) (SchemaGraphLib.type_of_node n))
- and expr_for_def sch n =
+ and expr_for_def ?(select=DbAst.SStar) sch n =
let ty = SchemaGraphLib.type_of_node n in
let _ =
let pos = QmlError.Context.get_pos ((V.label n).C.context) in
@@ -110,9 +110,24 @@ module Default = struct
| C.Hidden -> expr_aux sch (SchemaGraph.unique_next sch n)
| C.Sum -> H.convert_case_to_sum ty (expr_aux sch (E.dst (Schema_private.find_nonrec_child_edge sch n)))
| C.Product ->
+ let selected =
+ match select with
+ | DbAst.SFlds flds ->
+ (fun fld ->
+ List.find_map (fun (flds, s) -> if flds = [fld] then Some s else None) flds
+ )
+ | _ -> (fun _ -> Some (DbAst.SStar))
+ in
H.newexpr_annot
(QC.record
- (List.map (fun e -> SchemaGraphLib.fieldname_of_edge e, expr_aux sch (E.dst e)) (SchemaGraph0.succ_e sch n)))
+ (List.fold_right
+ (fun e acc ->
+ let fld = SchemaGraphLib.fieldname_of_edge e in
+ match selected fld with
+ | None -> acc
+ | Some s -> (fld, expr_aux ~select:s sch (E.dst e))::acc
+ ) (SchemaGraph0.succ_e sch n) []
+ ))
ty
| C.Leaf C.Leaf_int -> H.const_int 0
| C.Leaf C.Leaf_text -> H.const_string ""
@@ -121,9 +136,9 @@ module Default = struct
in H.end_built_pos ();
r
- let expr annotmap sch n =
+ let expr ?select annotmap sch n =
let () = H.AnnotTable.open_table ~annotmap:(Some annotmap) () in
- let e = expr_aux sch n in
+ let e = expr_aux ?select sch n in
(match H.AnnotTable.close_table () with
| None -> assert false
| Some a -> a, e)
View
@@ -23,6 +23,8 @@
module Format = BaseFormat
+module List = BaseList
+
module Graph = SchemaGraphLib.SchemaGraph.SchemaGraph0
module DbAst = QmlAst.Db
@@ -66,7 +68,7 @@ module Schema = struct
ty : QmlAst.ty;
kind : node_kind;
database : database;
- default : QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
+ default : ?select:QmlAst.expr DbAst.select -> QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
}
let pp_query fmt = function
@@ -304,7 +306,7 @@ module Schema = struct
| [], _ -> node, kind
| _::_, SetAccess (k, p, (Some _ as q), None) -> node, SetAccess(k, p, q, Some path)
| t::q, _ -> find q (find_next_step x t)
- in find path (get_root llschema, Compose [], [])
+ in find path (get_root llschema, Compose [], [])
in
let kind =
match kind with
@@ -335,9 +337,10 @@ module Schema = struct
| SetAccess (_, _, None, _) -> SchemaGraphLib.SchemaGraph.unique_next llschema node
| _ -> node
in
- fun annotmap ->
+ fun ?select annotmap ->
let (annotmap2, expr) =
DbGen_private.Default.expr
+ ?select
annotmap
llschema
node
@@ -357,6 +360,41 @@ module Schema = struct
module HacksForPositions = Sch.HacksForPositions
end
+module Utils = struct
+
+ let rec type_of_selected gamma ty select =
+ let ty = QmlTypesUtils.Inspect.follow_alias_noopt_private gamma ty in
+ let res = match select with
+ | DbAst.SNil | DbAst.SStar | DbAst.SSlice _ -> ty
+ | DbAst.SFlds sflds ->
+ match ty with
+ | QmlAst.TypeRecord (QmlAst.TyRow (rflds, rv)) ->
+ QmlAst.TypeRecord
+ (QmlAst.TyRow
+ ((List.filter_map
+ (fun (rfld, ty) ->
+ match List.find_map
+ (fun (sfld, s) -> if sfld = [rfld] then Some s else None)
+ sflds
+ with | None -> None
+ | Some s -> Some (rfld, type_of_selected gamma ty s)
+ )
+ rflds)
+ , rv)
+ )
+ | ty -> OManager.i_error "Try to select fields on %a" QmlPrint.pp#ty ty
+ in
+ #<If>
+ Format.eprintf "@[Type selection : %a.%a => %a@]@\n"
+ QmlPrint.pp#ty ty
+ (QmlAst.Db.pp_select (fun _ _ -> ())) select
+ QmlPrint.pp#ty res;
+ #<End>;
+ res
+
+
+end
+
module type S = sig include DbGenByPass.S end
type dbinfo = DbGen_private.dbinfo
@@ -74,7 +74,7 @@ module Schema: sig
ty : QmlAst.ty;
kind : node_kind;
database : database;
- default : QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
+ default : ?select:QmlAst.expr QmlAst.Db.select -> QmlAst.annotmap -> (QmlAst.annotmap * QmlAst.expr);
}
@@ -204,6 +204,12 @@ module Schema: sig
end
end
+module Utils : sig
+
+ val type_of_selected : QmlTypes.gamma -> QmlAst.ty -> 'a QmlAst.Db.select -> QmlAst.ty
+
+end
+
module type S = sig include DbGenByPass.S end
(** Internal type used to handle bindings in code generation *)

0 comments on commit 1aa37e7

Please sign in to comment.