# HG changeset patch # User Adam Chlipala # Date 1218922528 14400 # Node ID 2b665e822e9a7784d68c716bd312889cea0d5681 # Parent 5292c011302400c03f24821649da3536e451fe9b SQL boolean operators diff -r 5292c0113024 -r 2b665e822e9a lib/basis.lig --- a/lib/basis.lig Sat Aug 16 17:18:00 2008 -0400 +++ b/lib/basis.lig Sat Aug 16 17:35:28 2008 -0400 @@ -34,6 +34,17 @@ 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 -r 5292c0113024 -r 2b665e822e9a src/elaborate.sml --- a/src/elaborate.sml Sat Aug 16 17:18:00 2008 -0400 +++ b/src/elaborate.sml Sat Aug 16 17:35:28 2008 -0400 @@ -986,7 +986,7 @@ | 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 @@ 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 @@ (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 -r 5292c0113024 -r 2b665e822e9a src/lacweb.grm --- a/src/lacweb.grm Sat Aug 16 17:18:00 2008 -0400 +++ b/src/lacweb.grm Sat Aug 16 17:35:28 2008 -0400 @@ -86,7 +86,24 @@ 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 @@ | 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 @@ %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 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 -r 5292c0113024 -r 2b665e822e9a src/lacweb.lex --- a/src/lacweb.lex Sat Aug 16 17:18:00 2008 -0400 +++ b/src/lacweb.lex Sat Aug 16 17:35:28 2008 -0400 @@ -298,6 +298,9 @@ "TRUE" => (Tokens.TRUE (pos yypos, pos yypos + size yytext)); "FALSE" => (Tokens.FALSE (pos yypos, pos yypos + size yytext)); + "AND" => (Tokens.CAND (pos yypos, pos yypos + size yytext)); + "OR" => (Tokens.OR (pos yypos, pos yypos + size yytext)); + "NOT" => (Tokens.NOT (pos yypos, pos yypos + size yytext)); {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); diff -r 5292c0113024 -r 2b665e822e9a tests/where.lac --- a/tests/where.lac Sat Aug 16 17:18:00 2008 -0400 +++ b/tests/where.lac Sat Aug 16 17:35:28 2008 -0400 @@ -7,3 +7,4 @@ 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"}))