aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.lig11
-rw-r--r--src/elaborate.sml12
-rw-r--r--src/lacweb.grm29
-rw-r--r--src/lacweb.lex3
-rw-r--r--tests/where.lac1
5 files changed, 49 insertions, 7 deletions
diff --git a/lib/basis.lig b/lib/basis.lig
index 1343e449..e056acee 100644
--- a/lib/basis.lig
+++ b/lib/basis.lig
@@ -34,6 +34,17 @@ val sql_string : sql_type string
val sql_inject : tables ::: {{Type}} -> t ::: Type -> t -> sql_type t -> sql_exp tables t
+con sql_unary :: Type -> Type -> Type
+val sql_not : sql_unary bool bool
+val sql_unary : tables ::: {{Type}} -> arg ::: Type -> res ::: Type
+ -> sql_unary arg res -> sql_exp tables arg -> sql_exp tables res
+
+con sql_binary :: Type -> Type -> Type -> Type
+val sql_and : sql_binary bool bool bool
+val sql_or : sql_binary bool bool bool
+val sql_binary : tables ::: {{Type}} -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
+ -> sql_binary arg1 arg2 res -> sql_exp tables arg1 -> sql_exp tables arg2 -> sql_exp tables res
+
type sql_comparison
val sql_eq : sql_comparison
val sql_ne : sql_comparison
diff --git a/src/elaborate.sml b/src/elaborate.sml
index dc630e0e..58918dbd 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -986,7 +986,7 @@ datatype exp_error =
| Inexhaustive of ErrorMsg.span
| DuplicatePatField of ErrorMsg.span * string
| Unresolvable of ErrorMsg.span * L'.con
- | OutOfContext of ErrorMsg.span
+ | OutOfContext of ErrorMsg.span * (L'.exp * L'.con) option
fun expError env err =
case err of
@@ -1029,8 +1029,10 @@ fun expError env err =
ErrorMsg.errorAt loc "Inexhaustive 'case'"
| DuplicatePatField (loc, s) =>
ErrorMsg.errorAt loc ("Duplicate record field " ^ s ^ " in pattern")
- | OutOfContext loc =>
- ErrorMsg.errorAt loc "Type class wildcard occurs out of context"
+ | OutOfContext (loc, co) =>
+ (ErrorMsg.errorAt loc "Type class wildcard occurs out of context";
+ Option.app (fn (e, c) => eprefaces' [("Function", p_exp env e),
+ ("Type", p_con env c)]) co)
| Unresolvable (loc, c) =>
(ErrorMsg.errorAt loc "Can't resolve type class instance";
eprefaces' [("Class constraint", p_con env c)])
@@ -1466,10 +1468,10 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
(eerror, cerror, []))
| SOME pf => ((L'.EApp (e1', pf), loc), ran, gs1 @ gs2 @ gs3 @ gs4)
end
- | _ => (expError env (OutOfContext loc);
+ | _ => (expError env (OutOfContext (loc, SOME (e1', t1)));
(eerror, cerror, []))
end
- | L.EWild => (expError env (OutOfContext loc);
+ | L.EWild => (expError env (OutOfContext (loc, NONE));
(eerror, cerror, []))
| L.EApp (e1, e2) =>
diff --git a/src/lacweb.grm b/src/lacweb.grm
index 037f8d92..97d620db 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -86,7 +86,24 @@ fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
val e = (EApp (e, sqlexp1), loc)
val e = (EApp (e, sqlexp2), loc)
in
- (EApp (e, (EWild, loc)), loc)
+ (EApp (e, (EWild, loc)), loc)
+ end
+
+fun sql_binary (oper, sqlexp1, sqlexp2, loc) =
+ let
+ val e = (EVar (["Basis"], "sql_binary"), loc)
+ val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
+ val e = (EApp (e, sqlexp1), loc)
+ in
+ (EApp (e, sqlexp2), loc)
+ end
+
+fun sql_unary (oper, sqlexp, loc) =
+ let
+ val e = (EVar (["Basis"], "sql_unary"), loc)
+ val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper), loc)), loc)
+ in
+ (EApp (e, sqlexp), loc)
end
%%
@@ -113,7 +130,7 @@ fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
| BEGIN_TAG of string | END_TAG of string
| SELECT | FROM | AS | CWHERE
- | TRUE | FALSE
+ | TRUE | FALSE | CAND | OR | NOT
| NE | LT | LE | GT | GE
%nonterm
@@ -203,10 +220,13 @@ fun sql_compare (oper, sqlexp1, sqlexp2, loc) =
%nonassoc COLON
%nonassoc DCOLON TCOLON
%right COMMA
+%right OR
+%right CAND
%nonassoc EQ NE LT LE GT GE
%right ARROW LARROW
%right PLUSPLUS MINUSMINUS
%right STAR
+%left NOT
%nonassoc TWIDDLE
%nonassoc DOLLAR
%left DOT
@@ -670,9 +690,14 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True"),
| sqlexp GT sqlexp (sql_compare ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
| sqlexp GE sqlexp (sql_compare ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+ | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+ | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+ | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
+
| LBRACE eexp RBRACE (sql_inject (#1 eexp,
EWild,
s (LBRACEleft, RBRACEright)))
+ | LPAREN sqlexp RPAREN (sqlexp)
wopt : (sql_inject (EVar (["Basis"], "True"),
EVar (["Basis"], "sql_bool"),
diff --git a/src/lacweb.lex b/src/lacweb.lex
index e71974f6..70e55df7 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -298,6 +298,9 @@ notags = [^<{\n]+;
<INITIAL> "TRUE" => (Tokens.TRUE (pos yypos, pos yypos + size yytext));
<INITIAL> "FALSE" => (Tokens.FALSE (pos yypos, pos yypos + size yytext));
+<INITIAL> "AND" => (Tokens.CAND (pos yypos, pos yypos + size yytext));
+<INITIAL> "OR" => (Tokens.OR (pos yypos, pos yypos + size yytext));
+<INITIAL> "NOT" => (Tokens.NOT (pos yypos, pos yypos + size yytext));
<INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
diff --git a/tests/where.lac b/tests/where.lac
index 7152a62b..ac61d2c6 100644
--- a/tests/where.lac
+++ b/tests/where.lac
@@ -7,3 +7,4 @@ val q3 = (SELECT * FROM t1 WHERE FALSE)
val q4 = (SELECT * FROM t1 WHERE {True})
val q5 = (SELECT * FROM t1 WHERE {1} = {1})
val q6 = (SELECT * FROM t1 WHERE {"Hi"} < {"Bye"})
+val q7 = (SELECT * FROM t1 WHERE {1} <> {1} AND NOT ({"Hi"} >= {"Bye"}))
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 06:30:21 +0000