summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-07-16 13:59:30 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-07-16 13:59:30 -0400
commit7e10920b75383cd953898468385ae29e76bf184d (patch)
treeab868a5482914e1edd50ddce3be30c1a02a19de7 /src
parent662c635acece462b9a3d8f95f30716f9904b5ad5 (diff)
MySQL accepts generated demo DDL
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml3
-rw-r--r--src/mono_opt.sml4
-rw-r--r--src/monoize.sml46
-rw-r--r--src/mysql.sml28
-rw-r--r--src/postgres.sml4
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml8
7 files changed, 64 insertions, 33 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 13386f5b..835faad5 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2836,8 +2836,7 @@ fun p_sql env (ds, _) =
newline,
newline]
| DSequence s =>
- box [string "CREATE SEQUENCE ",
- string s,
+ box [string (#createSequence (Settings.currentDbms ()) s),
string ";",
newline,
newline]
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 9288b820..bf39b311 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -83,8 +83,8 @@ val urlifyString = String.translate (fn #" " => "+"
"%" ^ 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
diff --git a/src/monoize.sml b/src/monoize.sml
index aab2226b..2e9886dd 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -65,6 +65,12 @@ fun monoName env (all as (c, loc)) =
| _ => 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 @@ fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
(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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
_), _),
- (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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 =
diff --git a/src/mysql.sml b/src/mysql.sml
index bada72ed..d8847424 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1283,18 +1283,18 @@ fun dmlPrepared {loc, id, dml, inputs} =
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 p_cast (s, t) = "CAST(" ^ s ^ " AS " ^ p_sql_type t ^ ")"
+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, _) = s
fun p_blank _ = "?"
@@ -1312,6 +1312,8 @@ val () = addDbms {name = "mysql",
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
diff --git a/src/postgres.sml b/src/postgres.sml
index 7096a5cf..26825363 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -860,7 +860,9 @@ val () = addDbms {name = "postgres",
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"
diff --git a/src/settings.sig b/src/settings.sig
index bfbc1f82..873bbcb9 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -147,7 +147,9 @@ signature SETTINGS = sig
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
diff --git a/src/settings.sml b/src/settings.sml
index 32ab8bcd..99fa748d 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -337,7 +337,9 @@ type dbms = {
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 @@ val curDb = ref ({name = "",
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 =
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-04 23:23:42 +0000