From cd1f7af46e86eac77e8e855d726f0973e0a8e9e9 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Thu, 1 Sep 2016 17:37:20 +0000
Subject: [PATCH] Migration: Safe IsString instances for Field, Entity, Unique

---
 src/Data/Char/Local.hs         |  4 ++-
 src/Database/Persist/Schema.hs | 63 ++++++++++++++++++++++++++++++++++
 2 files changed, 66 insertions(+), 1 deletion(-)

diff --git a/src/Data/Char/Local.hs b/src/Data/Char/Local.hs
index 9dc1f40..53f9d95 100644
--- a/src/Data/Char/Local.hs
+++ b/src/Data/Char/Local.hs
@@ -21,8 +21,10 @@ where
 
 import Prelude
 
+import Data.Char
+
 isAsciiLetter :: Char -> Bool
-isAsciiLetter c = 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z'
+isAsciiLetter c = isAsciiLower c || isAsciiUpper c
 
 isNewline :: Char -> Bool
 isNewline c = c == '\n' || c == '\r'
diff --git a/src/Database/Persist/Schema.hs b/src/Database/Persist/Schema.hs
index 96362d0..2a692cf 100644
--- a/src/Database/Persist/Schema.hs
+++ b/src/Database/Persist/Schema.hs
@@ -31,15 +31,78 @@ import Prelude
 
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Reader (ReaderT)
+import Data.Char (isAsciiLower, isAsciiUpper)
+import Data.String (IsString (..))
 import Data.Text (Text)
 import Database.Persist.Types (SqlType)
 
+import qualified Data.Text as T (uncons, all, stripPrefix)
+
+import Data.Char.Local (isAsciiLetter)
+
 newtype FieldName = FieldName { unFieldName :: Text }
 
+instance IsString FieldName where
+    fromString s =
+        let t = fromString s
+        in  case T.uncons t of
+                Nothing     -> error "empty field name"
+                Just (c, r) ->
+                    if isAsciiLower c
+                        then
+                            if T.all isAsciiLetter r
+                                then FieldName t
+                                else
+                                    error "non ascii-letter char in field name"
+                        else
+                            error
+                                "field name doesn't start with lowercase \
+                                \ascii letter"
+
 newtype EntityName = EntityName { unEntityName :: Text }
 
+instance IsString EntityName where
+    fromString s =
+        let t = fromString s
+        in  case T.uncons t of
+                Nothing     -> error "empty entity name"
+                Just (c, r) ->
+                    if isAsciiUpper c
+                        then
+                            if T.all isAsciiLetter r
+                                then EntityName t
+                                else
+                                    error
+                                        "non ascii-letter char in entity name"
+                        else
+                            error
+                                "entity name doesn't start with uppercase \
+                                \ascii letter"
+
 newtype UniqueName = UniqueName { unUniqueName :: Text }
 
+instance IsString UniqueName where
+    fromString s =
+        let t = fromString s
+        in  case T.stripPrefix "Unique" t of
+                Nothing -> error "unique name doesn't start with \"Unique\""
+                Just u  ->
+                    case T.uncons u of
+                        Nothing     -> error "unique name is just \"Unique\""
+                        Just (c, r) ->
+                            if isAsciiUpper c
+                                then
+                                    if T.all isAsciiLetter r
+                                        then UniqueName t
+                                        else
+                                            error
+                                                "non ascii-letter char in \
+                                                \unique name"
+                                else
+                                    error
+                                        "unique name doesn't follow with \
+                                        \uppercase ascii letter after Unique"
+
 data FieldType = FTPrim SqlType | FTRef
 
 data MaybeNull = MaybeNull | NotNull