From 96f0331923f4ff4508175ab36a018e92525f7849 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 31 May 2019 12:41:51 -0400
Subject: Retool handling of text keys in MySQL

---
 src/cjr_print.sml      | 32 ++++++++++++++++++++++++++++++--
 src/monoize.sml        |  4 ++--
 tests/foreign_text.ur  |  4 ++++
 tests/foreign_text.urp |  5 +++++
 4 files changed, 41 insertions(+), 4 deletions(-)
 create mode 100644 tests/foreign_text.ur
 create mode 100644 tests/foreign_text.urp

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
-- 
cgit v1.2.3