Mercurial > urweb
changeset 877:dae141d911d9
MySQL accepts generated demo DDL
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Jul 2009 13:59:30 -0400 |
| parents | 025806b3c014 |
| children | a8952047e1d3 |
| files | src/cjr_print.sml src/mono_opt.sml src/monoize.sml src/mysql.sml src/postgres.sml src/settings.sig src/settings.sml |
| diffstat | 7 files changed, 63 insertions(+), 32 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/cjr_print.sml Thu Jul 16 13:59:30 2009 -0400 @@ -2836,8 +2836,7 @@ newline, newline] | DSequence s => - box [string "CREATE SEQUENCE ", - string s, + box [string (#createSequence (Settings.currentDbms ()) s), string ";", newline, newline]
--- a/src/mono_opt.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/mono_opt.sml Thu Jul 16 13:59:30 2009 -0400 @@ -83,8 +83,8 @@ "%" ^ hexIt ch) -fun sqlifyInt n = attrifyInt n ^ "::" ^ #p_sql_type (Settings.currentDbms ()) Settings.Int -fun sqlifyFloat n = attrifyFloat n ^ "::" ^ #p_sql_type (Settings.currentDbms ()) Settings.Float +fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int) +fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float) fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s
--- a/src/monoize.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/monoize.sml Thu Jul 16 13:59:30 2009 -0400 @@ -65,6 +65,12 @@ | _ => poly () end +fun lowercaseFirst "" = "" + | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) + ^ String.extract (s, 1, NONE) + +fun monoNameLc env c = lowercaseFirst (monoName env c) + fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TOption t, loc)), loc) fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), @@ -630,6 +636,12 @@ val readCookie = ref IS.empty +fun isBlobby (t : L.con) = + case #1 t of + L.CFfi ("Basis", "string") => true + | L.CFfi ("Basis", "blob") => true + | _ => false + fun monoExp (env, st, fm) (all as (e, loc)) = let val strcat = strcat loc @@ -1368,7 +1380,13 @@ ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), (L'.EPrim (Prim.String (String.concatWith ", " - (map (fn (x, _) => "uw_" ^ monoName env x) unique))), + (map (fn (x, _) => + "uw_" ^ monoNameLc env x + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique))), loc)), loc), fm) end @@ -1406,7 +1424,13 @@ val unique = (nm, t) :: unique in ((L'.EPrim (Prim.String ("UNIQUE (" - ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) + ^ String.concatWith ", " + (map (fn (x, t) => "uw_" ^ monoNameLc env x + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique) ^ ")")), loc), fm) end @@ -1447,18 +1471,20 @@ (L'.EAbs ("m", mat, mat, (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), [((L'.PPrim (Prim.String ""), loc), - (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ nm1)), + (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)), loc), string), - ("2", (L'.EPrim (Prim.String ("uw_" ^ nm2)), + ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)), loc), string)], loc)), ((L'.PWild, loc), (L'.ERecord [("1", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ nm1 ^ ", ")), + (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1 + ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( - (L'.EPrim (Prim.String ("uw_" ^ nm2 ^ ", ")), loc), + (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2 + ^ ", ")), loc), (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)], loc))], @@ -2146,7 +2172,7 @@ _), _), _), _), (L.CName tab, _)), _), - (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ field)), loc), fm) + (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2158,7 +2184,7 @@ _), _), _), _), _), _), - (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ nm)), loc), fm) + (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ lowercaseFirst nm)), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2412,10 +2438,6 @@ val (onload, attrs) = findOnload (attrs, []) - fun lowercaseFirst "" = "" - | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) - ^ String.extract (s, 1, NONE) - val (class, fm) = monoExp (env, st, fm) class fun tagStart tag =
--- a/src/mysql.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/mysql.sml Thu Jul 16 13:59:30 2009 -0400 @@ -1283,18 +1283,18 @@ fun nextval _ = box [] fun nextvalPrepared _ = box [] -fun sqlifyString s = "CAST('" ^ String.translate (fn #"'" => "\\'" - | #"\\" => "\\\\" - | ch => - if Char.isPrint ch then - str ch - else - (ErrorMsg.error - "Non-printing character found in SQL string literal"; - "")) - (String.toString s) ^ "' AS longtext)" +fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'" + | #"\\" => "\\\\" + | ch => + if Char.isPrint ch then + str ch + else + (ErrorMsg.error + "Non-printing character found in SQL string literal"; + "")) + (String.toString s) ^ "'" -fun p_cast (s, t) = "CAST(" ^ s ^ " AS " ^ p_sql_type t ^ ")" +fun p_cast (s, _) = s fun p_blank _ = "?" @@ -1312,6 +1312,8 @@ sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank, - supportsDeleteAs = false} + supportsDeleteAs = false, + createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTO_INCREMENT)", + textKeysNeedLengths = true} end
--- a/src/postgres.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/postgres.sml Thu Jul 16 13:59:30 2009 -0400 @@ -860,7 +860,9 @@ sqlifyString = sqlifyString, p_cast = p_cast, p_blank = p_blank, - supportsDeleteAs = true} + supportsDeleteAs = true, + createSequence = fn s => "CREATE SEQUENCE " ^ s, + textKeysNeedLengths = false} val () = setDbms "postgres"
--- a/src/settings.sig Sun Jul 12 16:09:54 2009 -0400 +++ b/src/settings.sig Thu Jul 16 13:59:30 2009 -0400 @@ -147,7 +147,9 @@ sqlifyString : string -> string, p_cast : string * sql_type -> string, p_blank : int * sql_type -> string (* Prepared statement input *), - supportsDeleteAs : bool + supportsDeleteAs : bool, + createSequence : string -> string, + textKeysNeedLengths : bool } val addDbms : dbms -> unit
--- a/src/settings.sml Sun Jul 12 16:09:54 2009 -0400 +++ b/src/settings.sml Thu Jul 16 13:59:30 2009 -0400 @@ -337,7 +337,9 @@ sqlifyString : string -> string, p_cast : string * sql_type -> string, p_blank : int * sql_type -> string, - supportsDeleteAs : bool + supportsDeleteAs : bool, + createSequence : string -> string, + textKeysNeedLengths : bool } val dbmses = ref ([] : dbms list) @@ -355,7 +357,9 @@ sqlifyString = fn s => s, p_cast = fn _ => "", p_blank = fn _ => "", - supportsDeleteAs = false} : dbms) + supportsDeleteAs = false, + createSequence = fn _ => "", + textKeysNeedLengths = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s =