___

MLstate · Jan 21, 2013 · ff251ce · ff251ce
1 parent fbc5b35
commit ff251ce
Show file tree

Hide file tree

Showing 5 changed files with 209 additions and 104 deletions.
diff --git a/compiler/libqmlcompil/dbGen/schema_private.ml b/compiler/libqmlcompil/dbGen/schema_private.ml
@@ -916,50 +916,51 @@ let type_of_sqldata gamma schema node ({Db. sql_fds; sql_tbs=_; sql_ops=_} as qu
     fields
   in Q.TypeRecord (Q.TyRow (fields, None))
 
+let simple_coerce new_annots wrap ty expr =
+  let e = QmlAstCons.UntypedExpr.coerce expr ty in
+  Q.QAnnot.expr e::new_annots, wrap e
 
-let coerce_query_element ~qwrap ~quwrap ~context gamma ty (query, options) =
-  let simple_coerce new_annots wrap ty expr =
-    let e = QmlAstCons.UntypedExpr.coerce expr ty in
-    Q.QAnnot.expr e::new_annots, wrap e
+
+let coerce_query_options options =
+  let a = [] in
+  let optmap f a o = match o with
+    | None -> a, None
+    | Some o -> let x, y = f a o in x, Some y in
+  let a, limit =
+    optmap
+      (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
+      a options.Db.limit
+  in let a, skip =
+    optmap
+      (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
+      a options.Db.skip
+  in let a, sort =
+    let ty =
+      Q.TypeSum (
+        let void = Q.TypeRecord (QmlAstCons.Type.Row.make []) in
+        QmlAstCons.Type.Col.make [
+          [("down", void)];
+          [("up", void)];
+        ]
+      )
+    in
+    optmap
+      (fun a fields ->
+         List.fold_left_map
+           (fun a (flds, e) -> simple_coerce a (fun e -> (flds, e)) ty e)
+           a fields
+      ) a options.Db.sort
   in
+  (a, {Db.limit; skip; sort})
+
+let coerce_query_element ~qwrap ~quwrap ~context gamma ty (query, options) =
   let coerce new_annots wrap ty expr =
     try
       let a, e = simple_coerce new_annots (fun e -> qwrap e) ty (quwrap expr) in
       a, wrap e
     with Not_found -> new_annots, wrap expr
   in
-  let a, options =
-    let a = [] in
-    let optmap f a o = match o with
-    | None -> a, None
-    | Some o -> let x, y = f a o in x, Some y in
-    let a, limit =
-      optmap
-        (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
-        a options.Db.limit
-    in let a, skip =
-      optmap
-        (fun a -> simple_coerce a (fun x -> x) (Q.TypeConst Q.TyInt))
-        a options.Db.skip
-    in let a, sort =
-      let ty =
-        Q.TypeSum (
-          let void = Q.TypeRecord (QmlAstCons.Type.Row.make []) in
-          QmlAstCons.Type.Col.make [
-            [("down", void)];
-            [("up", void)];
-          ]
-        )
-      in
-      optmap
-        (fun a fields ->
-           List.fold_left_map
-             (fun a (flds, e) -> simple_coerce a (fun e -> (flds, e)) ty e)
-             a fields
-        ) a options.Db.sort
-    in
-    (a, {Db.limit; skip; sort})
-  in
+  let a, options = coerce_query_options options in
   let rec aux new_annots ty query =
     let coerce = coerce new_annots in
     let aux2 wrap ty (q1, q2) =
@@ -1108,9 +1109,16 @@ let rec convert_dbpath ~context t gamma node kind select path0 path =
         in
         let ty = Q.TypeRecord (Q.TyRow (fields, None)) in
         let new_annots, (sql_ops, options) =
-          let qwrap x = `expr x in
-          let quwrap = function | `expr e -> e | _ -> raise Not_found in
-          coerce_query_element ~qwrap ~quwrap ~context gamma ty (sql_ops, options)
+          match sql_ops with
+          | None ->
+              let n, options = coerce_query_options options in
+              n, (sql_ops, options)
+          | Some q ->
+              let qwrap x = `expr x in
+              let quwrap = function | `expr e -> e | _ -> raise Not_found in
+              let a, (q, o) =
+                coerce_query_element ~qwrap ~quwrap ~context gamma ty (q, options)
+              in a, (Some q, o)
         in
         new_annots, (Db.SQLQuery ({Db.sql_tbs; sql_fds; sql_ops}, options))::[]
 

diff --git a/compiler/libqmlcompil/qmlAst.ml b/compiler/libqmlcompil/qmlAst.ml
@@ -163,7 +163,7 @@ struct
   type 'expr sqlquery = {
     sql_fds : (string * string) list;
     sql_tbs : string list;
-    sql_ops : ('expr, [`expr of 'expr | `bind of string]) query;
+    sql_ops : ('expr, [`expr of 'expr | `bind of string]) query option;
   }
 
   type 'expr query_options = {
@@ -391,12 +391,15 @@ struct
     );
     pp fmt " FROM ";
     (BaseFormat.pp_list "," Format.pp_print_string) fmt sql_tbs;
-    pp fmt " WHERE ";
-    let pp_qexpr fmt = function
-      | `expr e -> pp fmt "%a" pp_expr e
-      | `bind s -> Format.pp_print_string fmt s
-    in
-    (pp_query pp_expr pp_qexpr) fmt sql_ops
+    match sql_ops with
+    | None -> ()
+    | Some sql_ops ->
+        pp fmt " WHERE ";
+        let pp_qexpr fmt = function
+          | `expr e -> pp fmt "%a" pp_expr e
+          | `bind s -> Format.pp_print_string fmt s
+        in
+        (pp_query pp_expr pp_qexpr) fmt sql_ops
 
   let pp_path_elt pp_expr f =
     function
@@ -621,7 +624,9 @@ struct
         in
         TU.wrap
           (fun (sql_ops, o) -> SQLQuery ({sql_fds; sql_tbs; sql_ops}, o))
-          (TU.sub_2 (sub_db_query sub_e sub_eq sub_ty) (sub_db_query_options sub_e sub_ty)
+          (TU.sub_2
+             (TU.sub_option (sub_db_query sub_e sub_eq sub_ty))
+             (sub_db_query_options sub_e sub_ty)
              (sql_ops, o)
           )