Permalink
Browse files

[enhance] compiler: (big) improve path parser + opalang handles new q…

…uery/update node
  • Loading branch information...
BourgerieQuentin committed Jan 24, 2012
1 parent c197c0f commit 91ab51eab1503062a8322a0e5f10da0b6a7ec088

Large diffs are not rendered by default.

Oops, something went wrong.
@@ -454,8 +454,8 @@ let rec partial_match partial keylist =
##register [opacapi;restricted:dbgen,cps-bypass] set_dbset_keys : dbset('a), db_partial_key, continuation(dbset('a)) -> void
let set_dbset_keys dbset keys k = { dbset with keys = Array.of_list keys } |> k
-##register[cps-bypass] fold_dbset : dbset('a), 'acc, ('acc, 'a, continuation('acc) -> void), continuation('acc) -> void
-let fold_dbset dbset acc folder k =
+##register[cps-bypass] fold_dbset : 'acc, dbset('a), ('acc, 'a, continuation('acc) -> void), continuation('acc) -> void
+let fold_dbset acc dbset folder k =
let tr = dbset.transaction in
tr.tr_engine.E.read tr.tr dbset.path (Badop.Children (D.query (None, 0))) @>
function
View
@@ -150,6 +150,7 @@ struct
let opa2doc = !! "opa2doc"
let add_to_document = !! "add_to_document"
let indexes = !! "indexes"
+ let to_map = !! "to_map"
end
module Opa2Js =
@@ -497,11 +497,8 @@ just_se_expr <-
just_top_expr <-
/ just_se_expr
- / expr0:e1 write_expr?:e2 (* e1 <- e2 => e1 <- e2 normal expr + dbpath write *)
- {{
- match e2 with
- | Some e2 -> db_write e1 e2
- | None -> undecorate e1
+ / expr0:e1
+ {{ undecorate e1
}}
just_expr0 <- expr1:e (=exact_symbol("%"))?:o
@@ -550,7 +547,7 @@ just_expr10 <-
/ match
/ lambda
/ letin
- / Parser_path.query:v {{ let (path,access_kind) = v in DBPath (path, access_kind)}}
+ / Parser_path.path_kind:v {{ let (path,access_kind) = v in DBPath (path, access_kind)}}
(* FIXME: useful? / paths_opa_expr / props_aux*)
/ Css.css_map:e {{ undecorate e }} (* useful when saying some_style = ... *)
/ Trx.ExpressionAsFunction:e {{ parser_ e }}
@@ -988,6 +985,8 @@ record_fields_separator <- separator
record_fields_assign <- assign
+record_long_ident <- long_ident
+
extend_record_element <-
/ long_binding:b {{ `binding b }}
/ tilda:tilda (=deco(long_ident)):lp may_coerce:t not_assign
@@ -53,53 +53,127 @@ pathdef_type <- spacing pathdef_type_nosp:v {{ v }}
(* path for reading *)
;/** database query **/
-query <- querytype:qt path:p {{ p, qt }}
+path_kind <- querytype:qt path:p {{ p, qt }}
; /** database update path **/
path_update <-
/ slash_nosp path:pa Opa_lexer.larrow Opa_parser.expr:e
{{
DBPath (pa, QmlAst.Db.Update (QmlAst.Db.UExpr e))
}}
- / slash_nosp path:pa Opa_lexer.larrow update_expr:u
+ / slash_nosp path:pa Opa_lexer.larrow update:u
{{
DBPath (pa, QmlAst.Db.Update u)
}}
-update_expr <-
- / Opa_parser.expr:e {{ QmlAst.Db.UExpr e }}
+(* ******************************************************************)
+(**
+ {7 Path updating }
+*)
+update <-
/ lbrace update_fields:u rbrace {{ u }}
+ / Opa_parser.expr:e {{ QmlAst.Db.UExpr e }}
update_field <-
- / Opa_parser.long_ident:i (Opa_parser.record_fields_assign update_expr:e {{e}} / update_incr):e
- {{ (List.map undecorate i, e) }}
+ Opa_parser.record_long_ident:i (Opa_parser.record_fields_assign update:e {{e}} / update_incr / update_list):e
+ {{ (List.map undecorate i, e) }}
update_fields <-
(=list0(update_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
- {{ QmlAst.Db.UFields l }}
+ {{ QmlAst.Db.UFlds l }}
update_incr <-
/ (=Opa_lexer.exact_symbol("++"))
{{ QmlAst.Db.UIncr 1 }}
- / (=Opa_lexer.exact_symbol("+=")) Opa_lexer.spacing Opa_lexer.int:i
+ / (=Opa_lexer.exact_symbol("+=")) spacing Opa_lexer.int:i
{{ QmlAst.Db.UIncr i }}
/ (=Opa_lexer.exact_symbol("--"))
{{ QmlAst.Db.UIncr (-1) }}
- / (=Opa_lexer.exact_symbol("-=")) Opa_lexer.spacing Opa_lexer.int:i
+ / (=Opa_lexer.exact_symbol("-=")) spacing Opa_lexer.int:i
{{ QmlAst.Db.UIncr (-i) }}
+update_list <-
+ / (=Opa_lexer.exact_symbol("<+")) spacing Opa_parser.expr:e
+ {{ QmlAst.Db.UAppend e }}
+ / (=Opa_lexer.exact_symbol("<++")) spacing Opa_parser.expr:e
+ {{ QmlAst.Db.UAppendAll e }}
+ / (=Opa_lexer.exact_symbol("+>")) spacing Opa_parser.expr:e
+ {{ QmlAst.Db.UPrepend e }}
+ / (=Opa_lexer.exact_symbol("++>")) spacing Opa_parser.expr:e
+ {{ QmlAst.Db.UPrependAll e }}
+ / (=Opa_lexer.exact_ident("pop")) {{ QmlAst.Db.UPop }}
+ / (=Opa_lexer.exact_ident("shift")) {{ QmlAst.Db.UShift }}
+
+(* ******************************************************************)
+(**
+ {7 Path querying }
+*)
+query <-
+ / query_combine
+ / query_nocombine
+
+query_not <- (=Opa_lexer.exact_ident("not")) spacing query_nocombine:q
+ {{ QmlAst.Db.QNot q }}
+
+query_nocombine <-
+ / Opa_lexer.lpar query:q Opa_lexer.rpar {{ q }}
+ / query_simple
+ / query_not
+ / query_fields
+
+query_combine <-
+ / query_nocombine:q1 spacing query_double_builder:b spacing query:q2 {{ b q1 q2 }}
+ / Opa_lexer.lpar query:q1 Opa_lexer.rpar spacing query_double_builder:b spacing query:q2 {{ b q1 q2 }}
+
+query_simple_builder <-
+ / (=Opa_lexer.exact_symbol("==")) {{ fun e -> QmlAst.Db.QEq e }}
+ / (=Opa_lexer.exact_symbol(">")) {{ fun e -> QmlAst.Db.QGt e }}
+ / (=Opa_lexer.exact_symbol("<")) {{ fun e -> QmlAst.Db.QLt e }}
+ / (=Opa_lexer.exact_symbol(">=")) {{ fun e -> QmlAst.Db.QGte e }}
+ / (=Opa_lexer.exact_symbol("<=")) {{ fun e -> QmlAst.Db.QLte e }}
+ / (=Opa_lexer.exact_symbol("!=")) {{ fun e -> QmlAst.Db.QNe e }}
+ / (=Opa_lexer.exact_ident("in")) {{ fun e -> QmlAst.Db.QIn e }}
+
+query_simple <- query_nokeywords query_simple_builder:b query_expr:e {{ b e }}
+
+query_keywords <-
+ / (=Opa_lexer.exact_ident("and"))
+ / (=Opa_lexer.exact_ident("or"))
+
+query_nokeywords <-
+ / !query_keywords
+ (* / (=Opa_lexer.deco(query_keywords)):s *)
+ (* {{ *)
+ (* let k, a = s in *)
+ (* error1 (Printf.sprintf "Query keyword \"%s\" is used as a data field" k) a *)
+ (* }} *)
+
+query_double_builder <-
+ / (=Opa_lexer.exact_ident("and")) {{ fun q1 q2 -> QmlAst.Db.QAnd (q1, q2) }}
+ / (=Opa_lexer.exact_ident("or")) {{ fun q1 q2 -> QmlAst.Db.QOr (q1, q2) }}
+
+query_expr <- Opa_parser.expr
+
+query_field <- query_nokeywords Opa_parser.record_long_ident:i query_simple:q
+ {{ (List.map undecorate i, q) }}
+
+query_fields <- (=list0(query_field, Opa_parser.record_fields_separator)):l Opa_parser.record_fields_separator?
+ {{ QmlAst.Db.QFlds l }}
+
+
;querytype <- [?] slash_nosp {{ QmlAst.Db.Option }}
/ [!] slash_nosp {{ QmlAst.Db.Valpath }}
/ [@] slash_nosp {{ QmlAst.Db.Ref }}
/ slash_nosp {{ QmlAst.Db.Default }}
;path = Opa_parser.careful_deco just_path
-;just_path <- deco_ml_identifier_nosp:i path_elem*:l {{ let (s,label) = i in ((FldKey s),label) :: l }}
+;just_path <- deco_ml_identifier_nosp:i path_elem*:l {{ let (s,label) = i in ((QmlAst.Db.FldKey s),label) :: l }}
;path_elem = Opa_parser.careful_deco just_path_elem
-;just_path_elem <- slash_nosp ml_identifier_nosp:i {{ FldKey i }}
- / lbracket_nosp Opa_parser.expr:e rbracket {{ ExprKey e }}
- / lbracket_nosp spacing [?] rbracket {{ NewKey }}
+;just_path_elem <- slash_nosp ml_identifier_nosp:i {{ QmlAst.Db.FldKey i }}
+ / lbracket_nosp query:q rbracket {{ QmlAst.Db.Query q }}
+ / lbracket_nosp Opa_parser.expr:e rbracket {{ QmlAst.Db.ExprKey e }}
+ / lbracket_nosp spacing [?] rbracket {{ QmlAst.Db.NewKey }}
@@ -805,12 +805,7 @@ side_effect_expr <-
let l = list_expr_of_expr_list [a] p in
dom_transform l
}}
- / "@"? (=deco(Parser_path.path_write)):path (=deco(larrow)) expr:e2
- {{
- let (path,pos) = path in
- let path = (DBPath (path, QmlAst.Db.Ref),pos) in
- db_write path e2
- }}
+ / Parser_path.path_update
(* ******************************************************************)
@@ -844,7 +839,7 @@ expr_noop_simple <-
/ record / block (* Becareful : Keep this order for keep single fields record *)
/ tuple_expr
/ binding
- / Parser_path.query:v {{ let (p, k) = v in DBPath (p, k) }}
+ / Parser_path.path_kind:v {{ let (p, k) = v in DBPath (p, k) }}
(* FIXME: useful? / paths_opa_expr / props_aux*)
/ Css.css_map:e {{ undecorate e }} (* useful when saying some_style = ... *)
/ Trx.ExpressionAsFunction:e {{ parser_ e }}
@@ -1,95 +0,0 @@
-(*
- Copyright © 2011 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/>.
-*)
-(* shorcuts to other files *)
-;slash_nosp <- Opa_lexer.slash_nosp
-;deco_field_identifier_nosp <- Opa_parser.deco_field_identifier_nosp
-;field_identifier_nosp <- Opa_lexer.field_identifier_nosp
-;field_identifier <- Opa_lexer.field_identifier
-;underscore_nosp <- Opa_lexer.underscore_nosp
-;lbracket <- Opa_lexer.lbracket
-;lbracket_nosp <- Opa_lexer.lbracket_nosp
-;rbracket <- Opa_lexer.rbracket
-;rbracket_nosp <- Opa_lexer.rbracket_nosp
-;lbrace <- Opa_lexer.lbrace
-;lbrace_nosp <- Opa_lexer.lbrace_nosp
-;rbrace <- Opa_lexer.rbrace
-;rbrace_nosp <- Opa_lexer.rbrace_nosp
-;spacing <- Opa_lexer.spacing
-;semic <- Opa_lexer.semic
-
-(* path definition, ie for [db pathdef : typ] or [db pathdef = expr] *)
-;pathdef_nosp <-slash_nosp field_identifier_nosp:i
- (slash_nosp field_identifier_nosp:i {{QmlAst.Db.Decl_fld i}}
- / "[]" {{ QmlAst.Db.Decl_set [] }}
- / "[_]" {{ QmlAst.Db.Decl_set [] }})*:l
- {{ (QmlAst.Db.Decl_fld i)::l }}
-;/** todo: extend to multiple index **/
-setindex_def <- lbrace (=list1(field_identifier,semic)):i rbrace
- {{ QmlAst.Db.Decl_set [List.sort String.compare i] }}
-;pathdef_type_nosp <- slash_nosp field_identifier_nosp:i
- (slash_nosp field_identifier_nosp:i {{QmlAst.Db.Decl_fld i}}
- / lbracket setindex_def:i rbracket {{i}})*:l
- {{ (QmlAst.Db.Decl_fld i)::l }}
-;/** database path definition without type **/
-pathdef <- spacing pathdef_nosp:v {{ v }}
-;/** database path definition with type **/
-pathdef_type <- spacing pathdef_type_nosp:v {{ v }}
-
-
-(* path for reading *)
-;/** database query **/
-query <- querytype:qt path:p {{ p, qt }}
-
-(* path for writing (no leading !,@ etc.) *)
-; /** database write path **/
-path_write <- slash_nosp path:p {{ p }}
-
-;querytype <- [?] slash_nosp {{ QmlAst.Db.Option }}
- / [!] slash_nosp {{ QmlAst.Db.Valpath }}
- / [@] slash_nosp {{ QmlAst.Db.Ref }}
- / slash_nosp {{ QmlAst.Db.Default }}
-
-;path = Opa_parser.careful_deco just_path
-;just_path <- deco_field_identifier_nosp:i path_elem*:l {{ let (s,label) = i in ((FldKey s),label) :: l }}
-
-;path_elem = Opa_parser.careful_deco just_path_elem
-;just_path_elem <- slash_nosp field_identifier_nosp:i {{ FldKey i }}
- / lbracket_nosp Opa_parser.expr:e rbracket {{ ExprKey e }}
- / lbracket_nosp spacing [?] rbracket {{ NewKey }}
-
-
-
-
-(**
- {7 Separated lists}
-*)
-
-(** list where a the separator must occur *)
-let list2 element separator = element:e (separator element:e {{e}})+:l
- {{ e :: l }}
-
-(**Non-empty lists*)
-let list1 element separator = element:e (separator element {{__2}})*:l
- {{ e :: l }};
-
-(**Possibly empty lists*)
-let list0 element separator = (=list1(element,separator))?:o
- {{ match o with
- | None -> []
- | Some l -> l
- }}
View
@@ -118,7 +118,10 @@ let typed_val ?(label=Annot.nolabel "OpaMapToIdent") ?(side=`server) ?(ty=[]) ?(
let typ s =
opacapi_check s ;
- try StringMap.find s !r_type
+ Printf.eprintf "Lookup for %s%!\n" s;
+ try let x = StringMap.find s !r_type in
+ Format.eprintf " found %s\n%!" (QmlAst.TypeIdent.to_debug_string x);
+ x
with Not_found ->
OManager.i_error
"OpaMapToIdent: Type not found: %S\nIt contains:@\n%a@\n"
View
@@ -505,12 +505,13 @@ struct
and kind k = match k with
| QA.Db.Update update ->
- let rec aux_update = function
- | QA.Db.UExpr sa -> QA.Db.UExpr (expr sa)
- | QA.Db.UIncr _i as u -> u
- | QA.Db.UFields fields ->
- QA.Db.UFields (List.map (fun (f, u) -> (f, aux_update u)) fields)
- in QA.Db.Update (aux_update update)
+ let rebuild, exprs =
+ QmlAst.Db.sub_db_update
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ update in
+ let exprs' = List.map expr exprs in
+ QA.Db.Update (rebuild exprs')
| QA.Db.Default -> QA.Db.Default
| QA.Db.Option -> QA.Db.Option
| QA.Db.Valpath -> QA.Db.Valpath
@@ -627,11 +628,13 @@ struct
and db_path path =
- match path with
- | SA.FldKey s -> QA.Db.FldKey s
- | SA.ExprKey e -> QA.Db.ExprKey (expr e)
- | SA.NewKey -> QA.Db.NewKey
-
+ let rebuild, exprs =
+ QmlAst.Db.sub_path_elt
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ path in
+ let exprs' = List.map expr exprs in
+ rebuild exprs'
module DbConv =
View
@@ -248,15 +248,24 @@ struct
List.fold_left_map_stable
(fun acc db_elt ->
foldmap_1_stable
- (fun acc -> function
+ (fun acc elt ->
+ let rebuild, exprs =
+ QmlAst.Db.sub_path_elt
+ Traverse.Utils.sub_current
+ Traverse.Utils.sub_ignore
+ elt in
+ let acc, exprs' = List.fold_left_map_stable tra acc exprs in
+ acc, rebuild exprs'
+ )
+ (*fun acc -> function
| FldKey _
| NewKey as v -> acc, v
| ExprKey e as v ->
let acc, e' = tra acc e in
acc,
if e == e' then v else
ExprKey e'
- ) acc db_elt
+ *) acc db_elt
) acc node
) acc dbelt in
acc,
Oops, something went wrong.

0 comments on commit 91ab51e

Please sign in to comment.