summaryrefslogtreecommitdiff
path: root/src/monoize.sml
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
commitd59ec50a871633c463f3e670e964522da39f5020 (patch)
treeab868a5482914e1edd50ddce3be30c1a02a19de7 /src/monoize.sml
parent0240f6b83c282b74806c545daa48357e1e9fe0c4 (diff)
MySQL accepts generated demo DDL
Diffstat (limited to 'src/monoize.sml')
-rw-r--r--src/monoize.sml46
1 files changed, 34 insertions, 12 deletions
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 =