summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/ur/basis.urs15
-rw-r--r--src/monoize.sml39
-rw-r--r--src/urweb.grm54
-rw-r--r--src/urweb.lex3
-rw-r--r--tests/join.ur2
5 files changed, 111 insertions, 2 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index a67d007a..c80dde7c 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -246,6 +246,21 @@ val sql_left_join : tabs1 ::: {{Type}} -> tabs2 ::: {{(Type * Type)}}
-> sql_exp (tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool
-> sql_from_items (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2)
+val sql_right_join : tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{Type}}
+ -> [tabs1 ~ tabs2]
+ => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs1)
+ -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs1) -> sql_from_items tabs2
+ -> sql_exp (map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] bool
+ -> sql_from_items (map (map (fn p :: (Type * Type) => p.2)) tabs1 ++ tabs2)
+
+val sql_full_join : tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{(Type * Type)}}
+ -> [tabs1 ~ tabs2]
+ => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) (tabs1 ++ tabs2))
+ -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs1)
+ -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs2)
+ -> sql_exp (map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] bool
+ -> sql_from_items (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2))
+
val sql_query1 : tables ::: {{Type}}
-> grouped ::: {{Type}}
-> selectedFields ::: {{Type}}
diff --git a/src/monoize.sml b/src/monoize.sml
index 1a502e51..16839cf9 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1781,6 +1781,45 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc)), loc)), loc)), loc),
fm)
end
+ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)), _), _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("_", outerRec left,
+ (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+ (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("on", s, s,
+ strcat [(L'.EPrim (Prim.String "("), loc),
+ (L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " RIGHT JOIN "), loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc),
+ (L'.EPrim (Prim.String ")"), loc)]),
+ loc)), loc)), loc)), loc),
+ fm)
+ end
+ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _),
+ (L.CRecord (_, right), _)) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("_", outerRec (left @ right),
+ (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+ (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("on", s, s,
+ strcat [(L'.EPrim (Prim.String "("), loc),
+ (L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " FULL JOIN "), loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc),
+ (L'.EPrim (Prim.String ")"), loc)]),
+ loc)), loc)), loc)), loc),
+ fm)
+ end
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
((L'.EPrim (Prim.String ""), loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index c1f0b1ca..ce078279 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -213,7 +213,7 @@ datatype attr = Class of exp | Normal of con * exp
| CURRENT_TIMESTAMP
| NE | LT | LE | GT | GE
| CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
- | JOIN | INNER | CROSS | LEFT
+ | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
%nonterm
file of decl list
@@ -361,7 +361,7 @@ datatype attr = Class of exp | Normal of con * exp
%nonassoc DCOLON TCOLON
%left UNION INTERSECT EXCEPT
%right COMMA
-%right JOIN INNER CROSS LEFT
+%right JOIN INNER CROSS OUTER LEFT RIGHT FULL
%right OR
%right CAND
%nonassoc EQ NE LT LE GT GE IS
@@ -1478,6 +1478,56 @@ fitem : table' ([#1 table'], #2 table')
(#1 fitem1 @ #1 fitem2,
(EApp (e, sqlexp), loc))
end)
+ | fitem LEFT OUTER JOIN fitem ON sqlexp (let
+ val loc = s (fitem1left, sqlexpright)
+
+ val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
+ val e = (EApp (e, #2 fitem1), loc)
+ val e = (EApp (e, #2 fitem2), loc)
+ in
+ (#1 fitem1 @ #1 fitem2,
+ (EApp (e, sqlexp), loc))
+ end)
+ | fitem RIGHT JOIN fitem ON sqlexp (let
+ val loc = s (fitem1left, sqlexpright)
+
+ val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
+ val e = (EApp (e, #2 fitem1), loc)
+ val e = (EApp (e, #2 fitem2), loc)
+ in
+ (#1 fitem1 @ #1 fitem2,
+ (EApp (e, sqlexp), loc))
+ end)
+ | fitem RIGHT OUTER JOIN fitem ON sqlexp (let
+ val loc = s (fitem1left, sqlexpright)
+
+ val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
+ val e = (EApp (e, #2 fitem1), loc)
+ val e = (EApp (e, #2 fitem2), loc)
+ in
+ (#1 fitem1 @ #1 fitem2,
+ (EApp (e, sqlexp), loc))
+ end)
+ | fitem FULL JOIN fitem ON sqlexp (let
+ val loc = s (fitem1left, sqlexpright)
+
+ val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
+ val e = (EApp (e, #2 fitem1), loc)
+ val e = (EApp (e, #2 fitem2), loc)
+ in
+ (#1 fitem1 @ #1 fitem2,
+ (EApp (e, sqlexp), loc))
+ end)
+ | fitem FULL OUTER JOIN fitem ON sqlexp (let
+ val loc = s (fitem1left, sqlexpright)
+
+ val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
+ val e = (EApp (e, #2 fitem1), loc)
+ val e = (EApp (e, #2 fitem2), loc)
+ in
+ (#1 fitem1 @ #1 fitem2,
+ (EApp (e, sqlexp), loc))
+ end)
tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
| LBRACE cexp RBRACE (cexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index 517054b3..bb9004a6 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -341,7 +341,10 @@ notags = [^<{\n]+;
<INITIAL> "JOIN" => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
<INITIAL> "INNER" => (Tokens.INNER (pos yypos, pos yypos + size yytext));
<INITIAL> "CROSS" => (Tokens.CROSS (pos yypos, pos yypos + size yytext));
+<INITIAL> "OUTER" => (Tokens.OUTER (pos yypos, pos yypos + size yytext));
<INITIAL> "LEFT" => (Tokens.LEFT (pos yypos, pos yypos + size yytext));
+<INITIAL> "RIGHT" => (Tokens.RIGHT (pos yypos, pos yypos + size yytext));
+<INITIAL> "FULL" => (Tokens.FULL (pos yypos, pos yypos + size yytext));
<INITIAL> "UNION" => (Tokens.UNION (pos yypos, pos yypos + size yytext));
<INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext));
diff --git a/tests/join.ur b/tests/join.ur
index 74f49eec..d6647877 100644
--- a/tests/join.ur
+++ b/tests/join.ur
@@ -6,4 +6,6 @@ fun main () =
r <- oneRow (SELECT * FROM t AS T1 CROSS JOIN t AS T2);
r <- oneRow (SELECT * FROM t AS T1 JOIN t AS T2 ON T1.A = T2.A);
r <- oneRow (SELECT * FROM t AS T1 LEFT JOIN t AS T2 ON T1.A = T2.A);
+ r <- oneRow (SELECT * FROM t AS T1 RIGHT OUTER JOIN t AS T2 ON T1.A = T2.A);
+ r <- oneRow (SELECT * FROM t AS T1 FULL JOIN t AS T2 ON T1.A = T2.A);
return <xml/>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 05:24:51 +0000