add PersistText (thanks to @hansonkd)

examples/dbSpecificTypes.hs

@@ -10,9 +10,9 @@ data Point = Point { pointX :: Int, pointY :: Int } deriving Show
 
 -- PostgreSQL keeps point in format "(x,y)". This instance relies on the correspondence between Haskell tuple format and PostgreSQL point format.
 instance PrimitivePersistField Point where
-  toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y)
-  fromPrimitivePersistValue _ (PersistString a) = let (x, y) = read a in Point x y
-  fromPrimitivePersistValue _ (PersistByteString a) = let (x, y) = read (unpack a) in Point x y
+  toPrimitivePersistValue p (Point x y) = toPrimitivePersistValue p $ show (x, y)
+  fromPrimitivePersistValue p a = Point x y where
+    (x, y) = read $ fromPrimitivePersistValue p a
 
 instance PersistField Point where
   persistName _ = "Point"

groundhog-mysql/Database/Groundhog/MySQL.hs

@@ -607,6 +607,7 @@ newtype P = P PersistValue
 
 instance MySQL.Param P where
   render (P (PersistString t))      = MySQL.render t
+  render (P (PersistText t))        = MySQL.render t
   render (P (PersistByteString bs)) = MySQL.render bs
   render (P (PersistInt64 i))       = MySQL.render i
   render (P (PersistDouble d))      = MySQL.render d
@@ -654,8 +655,8 @@ getGetter MySQLBase.Year       = convertPV PersistDay
 -- Null
 getGetter MySQLBase.Null       = \_ _ -> PersistNull
 -- Controversial conversions
-getGetter MySQLBase.Set        = convertPV PersistString
-getGetter MySQLBase.Enum       = convertPV PersistString
+getGetter MySQLBase.Set        = convertPV PersistText
+getGetter MySQLBase.Enum       = convertPV PersistText
 -- Unsupported
 getGetter other = error $ "MySQL.getGetter: type " ++
                   show other ++ " not supported."

groundhog-postgresql/Database/Groundhog/Postgresql.hs

@@ -744,6 +744,7 @@ newtype P = P PersistValue
 
 instance PGTF.ToField P where
   toField (P (PersistString t))         = PGTF.toField t
+  toField (P (PersistText t))           = PGTF.toField t
   toField (P (PersistByteString bs))    = PGTF.toField (PG.Binary bs)
   toField (P (PersistInt64 i))          = PGTF.toField i
   toField (P (PersistDouble d))         = PGTF.toField d
@@ -764,19 +765,19 @@ getGetter :: PG.Oid -> Getter PersistValue
 getGetter (PG.Oid oid) = case oid of
   16   -> convertPV PersistBool
   17   -> convertPV (PersistByteString . unBinary)
-  18   -> convertPV PersistString
-  19   -> convertPV PersistString
+  18   -> convertPV PersistText
+  19   -> convertPV PersistText
   20   -> convertPV PersistInt64
   21   -> convertPV PersistInt64
   23   -> convertPV PersistInt64
-  25   -> convertPV PersistString
-  142  -> convertPV PersistString
+  25   -> convertPV PersistText
+  142  -> convertPV PersistText
   700  -> convertPV PersistDouble
   701  -> convertPV PersistDouble
   702  -> convertPV PersistUTCTime
   703  -> convertPV PersistUTCTime
-  1042 -> convertPV PersistString
-  1043 -> convertPV PersistString
+  1042 -> convertPV PersistText
+  1043 -> convertPV PersistText
   1082 -> convertPV PersistDay
   1083 -> convertPV PersistTimeOfDay
   1114 -> convertPV (PersistUTCTime . localTimeToUTC utc)

groundhog-postgresql/Database/Groundhog/Postgresql/Geometry.hs

@@ -73,7 +73,7 @@ points :: Parser [Point]
 points = point `sepBy1` char ','
 
 instance PrimitivePersistField Point where
-  toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y)
+  toPrimitivePersistValue p (Point x y) = toPrimitivePersistValue p $ show (x, y)
   fromPrimitivePersistValue _ = parseHelper point
 
 instance PersistField Point where
@@ -83,7 +83,7 @@ instance PersistField Point where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "point"]) False Nothing Nothing
 
 instance PrimitivePersistField Line where
-  toPrimitivePersistValue _ (Line (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
+  toPrimitivePersistValue p (Line (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue p $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = error "fromPrimitivePersistValue Line is not supported yet"
 
 instance PersistField Line where
@@ -93,7 +93,7 @@ instance PersistField Line where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "line"]) False Nothing Nothing
 
 instance PrimitivePersistField Lseg where
-  toPrimitivePersistValue _ (Lseg (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
+  toPrimitivePersistValue p (Lseg (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue p $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = parseHelper $ pair Lseg '[' ']' point
 
 instance PersistField Lseg where
@@ -103,7 +103,7 @@ instance PersistField Lseg where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "lseg"]) False Nothing Nothing
 
 instance PrimitivePersistField Box where
-  toPrimitivePersistValue _ (Box (Point x1 y1) (Point x2 y2)) = PersistString $ show ((x1, y1), (x2, y2))
+  toPrimitivePersistValue p (Box (Point x1 y1) (Point x2 y2)) = toPrimitivePersistValue p $ show ((x1, y1), (x2, y2))
   fromPrimitivePersistValue _ = parseHelper $ Box <$> (point <* char ',') <*> point
 
 instance PersistField Box where
@@ -123,7 +123,7 @@ showPoint :: Point -> ShowS
 showPoint (Point x y) = shows (x, y)
 
 instance PrimitivePersistField Path where
-  toPrimitivePersistValue _ path = PersistString $ case path of
+  toPrimitivePersistValue p path = toPrimitivePersistValue p $ case path of
     ClosedPath ps -> showPath '(' ')' ps ""
     OpenPath ps -> showPath '[' ']' ps ""
   fromPrimitivePersistValue _ = parseHelper $ path' ClosedPath '(' ')' <|> path' OpenPath '[' ']' where
@@ -136,7 +136,7 @@ instance PersistField Path where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "path"]) False Nothing Nothing
 
 instance PrimitivePersistField Polygon where
-  toPrimitivePersistValue _ (Polygon ps) = PersistString $ showPath '(' ')' ps ""
+  toPrimitivePersistValue p (Polygon ps) = toPrimitivePersistValue p $ showPath '(' ')' ps ""
   fromPrimitivePersistValue _ = parseHelper $ Polygon <$> (char '(' *> points <* char ')')
 
 instance PersistField Polygon where
@@ -146,7 +146,7 @@ instance PersistField Polygon where
   dbType _ _ = DbTypePrimitive (DbOther $ OtherTypeDef $ [Left "polygon"]) False Nothing Nothing
 
 instance PrimitivePersistField Circle where
-  toPrimitivePersistValue _ (Circle (Point x1 y1) r) = PersistString $ show ((x1, y1), r)
+  toPrimitivePersistValue p (Circle (Point x1 y1) r) = toPrimitivePersistValue p $ show ((x1, y1), r)
   fromPrimitivePersistValue _ = parseHelper $ Circle <$> (char '<' *> point) <* char ',' <*> double <* char '>'
 
 instance PersistField Circle where

groundhog-sqlite/Database/Groundhog/Sqlite.hs

@@ -445,6 +445,7 @@ bind stmt = go 1 where
   go i (x:xs) = do
     case x of
       PersistInt64 int64      -> S.bindInt64 stmt i int64
+      PersistText text        -> S.bindText stmt i $ text
       PersistString text      -> S.bindText stmt i $ T.pack text
       PersistDouble double    -> S.bindDouble stmt i double
       PersistBool b           -> S.bindInt64 stmt i $ if b then 1 else 0
@@ -493,7 +494,7 @@ queryRawCached' query vals = getStatementCached query >>= \stmt -> queryStmt stm
 pFromSql :: S.SQLData -> PersistValue
 pFromSql (S.SQLInteger i) = PersistInt64 i
 pFromSql (S.SQLFloat i)   = PersistDouble i
-pFromSql (S.SQLText s)    = PersistString (T.unpack s)
+pFromSql (S.SQLText s)    = PersistText s
 pFromSql (S.SQLBlob bs)   = PersistByteString bs
 pFromSql (S.SQLNull)      = PersistNull
 

groundhog/Database/Groundhog/Core.hs

@@ -100,6 +100,7 @@ import Control.Monad.Reader (MonadReader(..))
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Map (Map)
+import Data.Text (Text)
 import Data.Time (Day, TimeOfDay, UTCTime)
 import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone)
 import GHC.Exts (Constraint)
@@ -476,6 +477,7 @@ fromUtf8 (Utf8 a) = toByteString a
 -- | A raw value which can be stored in any backend and can be marshalled to
 -- and from a 'PersistField'.
 data PersistValue = PersistString String
+                  | PersistText Text
                   | PersistByteString ByteString
                   | PersistInt64 Int64
                   | PersistDouble Double

groundhog/Database/Groundhog/Generic/Sql.hs

@@ -238,6 +238,7 @@ renderChain RenderConfig{..} (f, prefix) acc = (case prefix of
 
 defaultShowPrim :: PersistValue -> String
 defaultShowPrim (PersistString x) = "'" ++ x ++ "'"
+defaultShowPrim (PersistText x) = "'" ++ show x ++ "'"
 defaultShowPrim (PersistByteString x) = "'" ++ show x ++ "'"
 defaultShowPrim (PersistInt64 x) = show x
 defaultShowPrim (PersistDouble x) = show x

groundhog/Database/Groundhog/Instances.hs

@@ -7,6 +7,7 @@ import Database.Groundhog.Generic (primToPersistValue, primFromPersistValue, pri
 
 import qualified Data.Aeson as A
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.Encoding.Error as T
 #if MIN_VERSION_base(4, 7, 0)
@@ -106,8 +107,9 @@ instance (PurePersistField a, PurePersistField b, PurePersistField c, PurePersis
     in ((a, b, c, d, e), rest4)
 
 instance PrimitivePersistField String where
-  toPrimitivePersistValue _ s = PersistString s
+  toPrimitivePersistValue _ s = PersistText (T.pack s)
   fromPrimitivePersistValue _ (PersistString s) = s
+  fromPrimitivePersistValue _ (PersistText s) = T.unpack s
   fromPrimitivePersistValue _ (PersistByteString bs) = T.unpack $ T.decodeUtf8With T.lenientDecode bs
   fromPrimitivePersistValue _ (PersistInt64 i) = show i
   fromPrimitivePersistValue _ (PersistDouble d) = show d
@@ -120,10 +122,15 @@ instance PrimitivePersistField String where
   fromPrimitivePersistValue _ (PersistCustom _ _) = error "Unexpected PersistCustom"
 
 instance PrimitivePersistField T.Text where
-  toPrimitivePersistValue _ a = PersistString (T.unpack a)
+  toPrimitivePersistValue _ s = PersistText s
+  fromPrimitivePersistValue _ (PersistText s) = s
   fromPrimitivePersistValue _ (PersistByteString bs) = T.decodeUtf8With T.lenientDecode bs
   fromPrimitivePersistValue p x = T.pack $ fromPrimitivePersistValue p x
 
+instance PrimitivePersistField TL.Text where
+  toPrimitivePersistValue p s = toPrimitivePersistValue p (TL.toStrict s)
+  fromPrimitivePersistValue p x = TL.fromStrict $ fromPrimitivePersistValue p x
+
 instance PrimitivePersistField ByteString where
   toPrimitivePersistValue _ s = PersistByteString s
   fromPrimitivePersistValue _ (PersistByteString a) = a
@@ -241,6 +248,7 @@ instance PrimitivePersistField a => SinglePersistField a where
 
 instance NeverNull String
 instance NeverNull T.Text
+instance NeverNull TL.Text
 instance NeverNull ByteString
 instance NeverNull Lazy.ByteString
 instance NeverNull Int
@@ -264,6 +272,7 @@ instance NeverNull (KeyForBackend db v)
 readHelper :: Read a => PersistValue -> String -> a
 readHelper s errMessage = case s of
   PersistString str -> readHelper' str
+  PersistText str -> readHelper' (T.unpack str)
   PersistByteString str -> readHelper' (unpack str)
   _ -> error $ "readHelper: " ++ errMessage
   where
@@ -295,6 +304,12 @@ instance PersistField T.Text where
   fromPersistValues = primFromPersistValue
   dbType _ _ = DbTypePrimitive DbString False Nothing Nothing
 
+instance PersistField TL.Text where
+  persistName _ = "Text"
+  toPersistValues = primToPersistValue
+  fromPersistValues = primFromPersistValue
+  dbType _ _ = DbTypePrimitive DbString False Nothing Nothing
+
 instance PersistField Int where
   persistName _ = "Int"
   toPersistValues = primToPersistValue
@@ -625,7 +640,7 @@ instance Constructor c => EntityConstr' HTrue c where
   entityConstrNum' _ = phantomConstrNum
 
 instance A.FromJSON PersistValue where
-  parseJSON (A.String t) = return $ PersistString $ T.unpack t
+  parseJSON (A.String t) = return $ PersistText t
 #if MIN_VERSION_aeson(0, 7, 0)
   parseJSON (A.Number n) = return $
     if fromInteger (floor n) == n
@@ -641,6 +656,7 @@ instance A.FromJSON PersistValue where
 
 instance A.ToJSON PersistValue where
   toJSON (PersistString t) = A.String $ T.pack t
+  toJSON (PersistText t) = A.String t
   toJSON (PersistByteString b) = A.String $ T.decodeUtf8 $ B64.encode b
   toJSON (PersistInt64 i) = A.Number $ fromIntegral i
   toJSON (PersistDouble d) = A.Number $