From eb715ea49f6d74f5ac7b7f2967f4a86c4db0a75f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 12 Mar 2016 20:44:00 -0500 Subject: Use IS NOT DISTINCT FROM; improve Sql parser --- src/monoize.sml | 43 +++++++++++++++++++++++++------------------ src/mysql.sml | 3 ++- src/postgres.sml | 3 ++- src/settings.sig | 3 ++- src/settings.sml | 6 ++++-- src/sql.sml | 13 ++++++++++--- src/sqlcache.sml | 8 ++++---- src/sqlite.sml | 3 ++- 8 files changed, 51 insertions(+), 31 deletions(-) (limited to 'src') diff --git a/src/monoize.sml b/src/monoize.sml index 6715290f..6979474e 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2326,24 +2326,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val body = case #1 arg1 of L.CApp ((L.CFfi ("Basis", "option"), _), _) => - (L'.ECase ((L'.ERel 2, loc), - [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), - strcat [str "((", - (L'.ERel 1, loc), - str " ", - (L'.ERel 2, loc), - str " ", - (L'.ERel 0, loc), - str ") OR ((", - (L'.ERel 1, loc), - str ") IS NULL AND (", - (L'.ERel 0, loc), - str ") IS NULL))"]), - ((L'.PVar ("_", s), loc), - default 1)], - {disc = s, - result = s}), loc) - | _ => default 0 + (L'.ECase ((L'.ERel 2, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), + if #supportsIsDistinctFrom (Settings.currentDbms ()) then + strcat [str "((", + (L'.ERel 1, loc), + str " IS NOT DISTINCT FROM ", + (L'.ERel 0, loc), + str "))"] + else + strcat [str "((", + (L'.ERel 1, loc), + str " ", + (L'.ERel 2, loc), + str " ", + (L'.ERel 0, loc), + str ") OR ((", + (L'.ERel 1, loc), + str ") IS NULL AND (", + (L'.ERel 0, loc), + str ") IS NULL))"]), + ((L'.PVar ("_", s), loc), + default 1)], + {disc = s, + result = s}), loc) + | _ => default 0 in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), diff --git a/src/mysql.sml b/src/mysql.sml index 692be0a2..539428f6 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1608,6 +1608,7 @@ val () = addDbms {name = "mysql", falseString = "FALSE", onlyUnion = true, nestedRelops = false, - windowFunctions = false} + windowFunctions = false, + supportsIsDistinctFrom = true} end diff --git a/src/postgres.sml b/src/postgres.sml index 1c95f414..ddfe0ad6 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1145,7 +1145,8 @@ val () = addDbms {name = "postgres", falseString = "FALSE", onlyUnion = false, nestedRelops = true, - windowFunctions = true} + windowFunctions = true, + supportsIsDistinctFrom = true} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index c75f12a3..5b54ed44 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -213,7 +213,8 @@ signature SETTINGS = sig falseString : string, onlyUnion : bool, nestedRelops : bool, - windowFunctions : bool + windowFunctions : bool, + supportsIsDistinctFrom : bool } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index 38ea30fc..d689824e 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -621,7 +621,8 @@ type dbms = { falseString : string, onlyUnion : bool, nestedRelops : bool, - windowFunctions: bool + windowFunctions: bool, + supportsIsDistinctFrom : bool } val dbmses = ref ([] : dbms list) @@ -653,7 +654,8 @@ val curDb = ref ({name = "", falseString = "", onlyUnion = false, nestedRelops = false, - windowFunctions = false} : dbms) + windowFunctions = false, + supportsIsDistinctFrom = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = diff --git a/src/sql.sml b/src/sql.sml index e8e82196..409e205c 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -221,6 +221,7 @@ datatype sqexp = fun cmp s r = wrap (const s) (fn () => RCmp r) val sqbrel = altL [cmp "=" Eq, + cmp "IS NOT DISTINCT FROM" Eq, cmp "<>" Ne, cmp "<=" Le, cmp "<" Lt, @@ -334,11 +335,12 @@ fun sqexp chs = (altL [wrap (if !sqlcacheMode then primSqlcache else prim) SqConst, wrap (const "TRUE") (fn () => SqTrue), wrap (const "FALSE") (fn () => SqFalse), + wrap (follow (const "NULL::") ident) (fn ((), _) => Null), wrap (const "NULL") (fn () => Null), - wrap field Field, - wrap uw_ident Computed, wrap known SqKnown, wrap func SqFunc, + wrap field Field, + wrap uw_ident Computed, wrap (arithmetic sqexp) (fn _ => Unmodeled), wrap unmodeled (fn () => Unmodeled), wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, @@ -402,6 +404,11 @@ val orderby = log "orderby" (opt (ws (const "DESC")))))) ignore) +val groupby = log "groupby" + (wrap (follow (ws (const "GROUP BY ")) + (list sqexp)) + ignore) + val jtype = altL [wrap (const "JOIN") (fn () => Inner), wrap (const "LEFT JOIN") (fn () => Left), wrap (const "RIGHT JOIN") (fn () => Right), @@ -444,7 +451,7 @@ and query chs = log "query" (follow query (const "))"))))) (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) (wrap query1 Query1)) - (opt orderby)) + (follow (opt groupby) (opt orderby))) #1) chs diff --git a/src/sqlcache.sml b/src/sqlcache.sml index c97daac2..83a264fd 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1370,9 +1370,9 @@ fun cacheExp (env, exp', invalInfo, state : state) = (case arg of AsIs exp => SOME exp | Urlify exp => - typOfExp env exp + (typOfExp env exp) <\obind\> - (fn typ => (MonoFooify.urlify env (exp, typ)))) + (fn typ => MonoFooify.urlify env (exp, typ))) <\obind\> (fn arg' => SOME (arg' :: args')))) (SOME []) @@ -1588,12 +1588,12 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state val inval = case Sql.parse Sql.dml dmlText of SOME dmlParsed => - SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of + SOME (map (fn i => case IM.find (indexToInvalInfo, i) of SOME invalInfo => (i, invalidations (invalInfo, dmlParsed)) (* TODO: fail more gracefully. *) (* This probably means invalidating everything.... *) - | NONE => raise Fail "Sqlcache: addFlushing (a)")) + | NONE => raise Fail "Sqlcache: addFlushing (a)") (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) | NONE => NONE in diff --git a/src/sqlite.sml b/src/sqlite.sml index a1095709..c7694cde 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -849,6 +849,7 @@ val () = addDbms {name = "sqlite", falseString = "0", onlyUnion = false, nestedRelops = false, - windowFunctions = false} + windowFunctions = false, + supportsIsDistinctFrom = true} end -- cgit v1.2.3