Mercurial > urweb
diff src/monoize.sml @ 877:dae141d911d9
MySQL accepts generated demo DDL
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 16 Jul 2009 13:59:30 -0400 |
| parents | 3c7b48040dcf |
| children | 5805fa825fe8 |
line wrap: on
line diff
--- 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 =