diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2019-05-31 12:41:51 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2019-05-31 12:41:51 -0400 |
| commit | 96f0331923f4ff4508175ab36a018e92525f7849 (patch) | |
| tree | b236bb9e20733adbe32a4d20f2fe41ae12f22086 | |
| parent | 77535d0da9780d7eb0f02b04494da02374d36545 (diff) | |
Retool handling of text keys in MySQL
| -rw-r--r-- | src/cjr_print.sml | 32 | ||||
| -rw-r--r-- | src/monoize.sml | 4 | ||||
| -rw-r--r-- | tests/foreign_text.ur | 4 | ||||
| -rw-r--r-- | tests/foreign_text.urp | 5 |
4 files changed, 41 insertions, 4 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 4aa8d51e..b9795194 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3744,6 +3744,26 @@ fun p_file env (ds, ps) = newline] end +fun isText t = + case t of + String => true + | Nullable t => isText t + | _ => false + +fun declaresAsForeignKey xs s = + case String.tokens (fn ch => Char.isSpace ch orelse ch = #"," orelse ch = #"(" orelse ch = #")") s of + "FOREIGN" :: "KEY" :: rest => + let + fun consume rest = + case rest of + [] => false + | "REFERENCES" :: _ => false + | xs' :: rest' => xs' = xs orelse consume rest' + in + consume rest + end + | _ => false + fun p_sql env (ds, _) = let val (pps, _) = ListUtil.foldlMap @@ -3756,11 +3776,19 @@ fun p_sql env (ds, _) = string "(", p_list (fn (x, t) => let + val xs = Settings.mangleSql (CharVector.map Char.toLower x) val t = sql_type_in env t + + val ts = if #textKeysNeedLengths (Settings.currentDbms ()) andalso isText t + andalso (List.exists (declaresAsForeignKey xs o #2) csts + orelse List.exists (String.isSubstring (xs ^ "(255)")) (pk :: map #2 csts)) then + "varchar(255)" + else + #p_sql_type (Settings.currentDbms ()) t in - box [string (Settings.mangleSql (CharVector.map Char.toLower x)), + box [string xs, space, - string (#p_sql_type (Settings.currentDbms ()) t), + string ts, case t of Nullable _ => box [] | _ => string " NOT NULL"] diff --git a/src/monoize.sml b/src/monoize.sml index 97ad1505..4aeddcae 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1369,7 +1369,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique)))), loc), @@ -1413,7 +1413,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique) ^ ")"), diff --git a/tests/foreign_text.ur b/tests/foreign_text.ur new file mode 100644 index 00000000..8f404349 --- /dev/null +++ b/tests/foreign_text.ur @@ -0,0 +1,4 @@ +table t : { A : string } PRIMARY KEY A +table u : { A : string } CONSTRAINT A FOREIGN KEY A REFERENCES t(A) + +val main : transaction page = return <xml></xml> diff --git a/tests/foreign_text.urp b/tests/foreign_text.urp new file mode 100644 index 00000000..f0777eb6 --- /dev/null +++ b/tests/foreign_text.urp @@ -0,0 +1,5 @@ +dbms mysql +database dbname=foreign_text +sql foreign_text.sql + +foreign_text |