Add proper support for Word64

persistent-mongoDB/Database/Persist/MongoDB.hs

@@ -1040,6 +1040,7 @@ instance DB.Val PersistValue where
   val (PersistByteString x) = DB.Bin (DB.Binary x)
   val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x
   val (PersistTimeOfDay _)  = throw $ PersistMongoDBUnsupported "PersistTimeOfDay not implemented for the MongoDB backend. only PersistUTCTime currently implemented"
+  val (PersistWord64 _)     = throw $ PersistMongoDBUnsupported "PersistWord64 not implemented for the MongoDB backend"
   val (PersistRational _)   = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend"
   val (PersistArray a)      = DB.val $ PersistList a
   val (PersistDbSpecific _)   = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend"

persistent-mysql/Database/Persist/MySQL.hs

@@ -225,6 +225,7 @@ instance MySQL.Param P where
     render (P (PersistText t))        = MySQL.render t
     render (P (PersistByteString bs)) = MySQL.render bs
     render (P (PersistInt64 i))       = MySQL.render i
+    render (P (PersistWord64 i))      = MySQL.render i
     render (P (PersistDouble d))      = MySQL.render d
     render (P (PersistBool b))        = MySQL.render b
     render (P (PersistDay d))         = MySQL.render d
@@ -785,6 +786,7 @@ showSqlType SqlDay     _          _     = "DATE"
 showSqlType SqlDayTime _          _     = "DATETIME"
 showSqlType SqlInt32   _          _     = "INT(11)"
 showSqlType SqlInt64   _          _     = "BIGINT"
+showSqlType SqlWord64   _          _    = "NUMERIC(20,0)" -- length (show (maxBound :: Word64))
 showSqlType SqlReal    _          _     = "DOUBLE"
 showSqlType (SqlNumeric s prec) _ _     = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")"
 showSqlType SqlString  Nothing    True  = "TEXT CHARACTER SET utf8mb4"

persistent-postgresql/ChangeLog.md

@@ -11,6 +11,8 @@
   * added `runConn_` to run a db connection and return result
   * Renamed `db` to `runConnAssert` in `test/PgInit.hs` for clarity
   * Ran `test/ArrayAggTest.hs` (which was previously written but not being run)
+* [#1096](https://github.com/yesodweb/persistent/pull/1096)
+  * Add proper support for `Word64`.
 
 ## 2.10.1.2
 

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -428,6 +428,7 @@ instance PGTF.ToField P where
     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 (PersistWord64 i))      = PGTF.toField i
     toField (P (PersistDouble d))      = PGTF.toField d
     toField (P (PersistRational r))    = PGTF.Plain $
                                          BBB.fromString $
@@ -1110,6 +1111,7 @@ showSqlType :: SqlType -> Text
 showSqlType SqlString = "VARCHAR"
 showSqlType SqlInt32 = "INT4"
 showSqlType SqlInt64 = "INT8"
+showSqlType SqlWord64 = "NUMERIC(20,0)" -- length (show (maxBound :: Word64)) == 20
 showSqlType SqlReal = "DOUBLE PRECISION"
 showSqlType (SqlNumeric s prec) = T.concat [ "NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")" ]
 showSqlType SqlDay = "DATE"

persistent-redis/Database/Persist/Redis/Parser.hs

@@ -16,7 +16,7 @@ import Data.Int (Int64)
 import Data.Text (Text, unpack)
 import qualified Data.Text as T
 import Data.Time
-import Data.Word (Word8)
+import Data.Word (Word8, Word64)
 
 import Database.Persist.Types
 import Database.Persist.Redis.Exception
@@ -126,6 +126,10 @@ instance Binary BinPersistValue where
         put (12 :: Word8)
         put x
 
+    put (BinPersistValue (PersistWord64 x)) = do
+        put (13 :: Word8)
+        put x
+
     put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray"
     put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific"
     put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId"
@@ -149,7 +153,7 @@ instance Binary BinPersistValue where
                 10-> liftM (PersistList . map unBinPersistValue) (Q.get :: Get [BinPersistValue])
                 11-> liftM (PersistMap . map (unBinText *** unBinPersistValue)) (Q.get :: Get [(BinText, BinPersistValue)])
                 12-> liftM PersistRational (Q.get :: Get Rational)
---                13-> liftM (PersistZonedTime . unBinZT) (Q.get :: Get BinZT)
+                13-> liftM PersistWord64 (Q.get :: Get Word64)
                 z -> throw $ ParserError ("Incorrect tag " ++ show z ++ " came to Binary deserialization")
         liftM BinPersistValue pv
 
@@ -160,4 +164,4 @@ castOne :: B.ByteString -> PersistValue
 castOne = unBinPersistValue . Q.decode . L.fromStrict
 
 redisToPerisistValues :: [(B.ByteString, B.ByteString)] -> [PersistValue]
-redisToPerisistValues = map (castOne . snd)
+redisToPerisistValues = map (castOne . snd)

persistent-sqlite/Database/Persist/Sqlite.hs

@@ -382,6 +382,7 @@ showSqlType :: SqlType -> Text
 showSqlType SqlString = "VARCHAR"
 showSqlType SqlInt32 = "INTEGER"
 showSqlType SqlInt64 = "INTEGER"
+showSqlType SqlWord64 = "INTEGER"
 showSqlType SqlReal = "REAL"
 showSqlType (SqlNumeric precision scale) = T.concat [ "NUMERIC(", T.pack (show precision), ",", T.pack (show scale), ")" ]
 showSqlType SqlDay = "DATE"

persistent/ChangeLog.md

@@ -20,6 +20,8 @@
 * Fix a bug where unsafe migration error messages were being shown using `Show` prior to printing, resulting in less helpful output. [#1080](https://github.com/yesodweb/persistent/pull/1080)
 * [#1087](https://github.com/yesodweb/persistent/pull/1087)
   * `RawSql` now has tuple instances up to GHC's max tuple size (62)
+* [#1096](https://github.com/yesodweb/persistent/pull/1096)
+  * Add proper support for `Word64`.
 
 ## 2.10.5.2
 
@@ -30,7 +32,7 @@
 ## 2.10.5.1
 
 * [#1024](https://github.com/yesodweb/persistent/pull/1024)
-    * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. 
+    * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities.
     * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi`
 
 ## 2.10.5

persistent/Database/Persist/Class/PersistField.hs

@@ -19,6 +19,7 @@ import Data.Int (Int8, Int16, Int32, Int64)
 import qualified Data.IntMap as IM
 import qualified Data.Map as M
 import Data.Monoid ((<>))
+import Data.Ratio (denominator, numerator)
 import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -101,6 +102,7 @@ instance {-# OVERLAPPING #-} PersistField [Char] where
     fromPersistValue (PersistByteString bs) =
         Right $ T.unpack $ TE.decodeUtf8With TERR.lenientDecode bs
     fromPersistValue (PersistInt64 i) = Right $ Prelude.show i
+    fromPersistValue (PersistWord64 i) = Right $ Prelude.show i
     fromPersistValue (PersistDouble d) = Right $ Prelude.show d
     fromPersistValue (PersistRational r) = Right $ Prelude.show r
     fromPersistValue (PersistDay d) = Right $ Prelude.show d
@@ -226,8 +228,13 @@ instance PersistField Word32 where
     fromPersistValue x = Left $ fromPersistValueError "Word32" "integer" x
 
 instance PersistField Word64 where
-    toPersistValue = PersistInt64 . fromIntegral
+    toPersistValue = PersistWord64 . fromIntegral
+    fromPersistValue (PersistWord64 w) = Right $ fromIntegral w
     fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
+    fromPersistValue x@(PersistRational r) = if denominator r == 1
+                                               then Right $ fromIntegral (numerator r)
+                                               else Left $ fromPersistValueError "Word64" "rational" x
+    fromPersistValue x@(PersistDouble 0.0) = Right 0
     fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x
 
 instance PersistField Double where

persistent/Database/Persist/Sql/Class.hs

@@ -1203,7 +1203,7 @@ instance PersistFieldSql Word16 where
 instance PersistFieldSql Word32 where
     sqlType _ = SqlInt64
 instance PersistFieldSql Word64 where
-    sqlType _ = SqlInt64
+    sqlType _ = SqlWord64
 instance PersistFieldSql Double where
     sqlType _ = SqlReal
 instance PersistFieldSql Bool where

persistent/Database/Persist/Sql/Orphan/PersistQuery.hs

@@ -46,6 +46,7 @@ instance PersistQueryRead SqlBackend where
             mm <- CL.head
             case mm of
               Just [PersistInt64 i] -> return $ fromIntegral i
+              Just [PersistWord64 i] -> return $ fromIntegral i
               Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle
               Just [PersistByteString i] -> case readInteger i of -- gb mssql
                                               Just (ret,"") -> return $ fromIntegral ret
@@ -116,6 +117,7 @@ instance PersistQueryRead SqlBackend where
                       Nothing ->
                         case xs of
                            [PersistInt64 x] -> return [PersistInt64 x]
+                           [PersistWord64 x] -> return [PersistWord64 x]
                            [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double
                            _ -> return xs
                       Just pdef ->

persistent/Database/Persist/Sql/Orphan/PersistStore.hs

@@ -155,6 +155,9 @@ instance PersistStoreWrite SqlBackend where
                         Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of
                             Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err
                             Right k -> return k
+                        Just [PersistWord64 i] -> case keyFromValues [PersistWord64 i] of
+                            Left err -> error $ "SQL insert: keyFromValues: PersistWord64 " `mappend` show i `mappend` " " `mappend` unpack err
+                            Right k -> return k
                         Nothing -> error $ "SQL insert did not return a result giving the generated ID"
                         Just vals' -> case keyFromValues vals' of
                             Left e -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ++ ". Error was: " ++ unpack e

persistent/Database/Persist/Types/Base.hs

@@ -22,7 +22,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 import Data.Time (Day, TimeOfDay, UTCTime)
 import Data.Typeable (Typeable)
 import qualified Data.Vector as V
-import Data.Word (Word32)
+import Data.Word (Word32, Word64)
 import Numeric (showHex, readHex)
 import Web.PathPieces (PathPiece(..))
 import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData)
@@ -368,6 +368,7 @@ instance Error PersistException where
 data PersistValue = PersistText Text
                   | PersistByteString ByteString
                   | PersistInt64 Int64
+                  | PersistWord64 Word64  -- @since 2.11.0
                   | PersistDouble Double
                   | PersistRational Rational
                   | PersistBool Bool
@@ -417,6 +418,7 @@ instance ToHttpApiData PersistValue where
 instance FromHttpApiData PersistValue where
     parseUrlPiece input =
           PersistInt64 <$> parseUrlPiece input
+      <!> PersistWord64 <$> parseUrlPiece input
       <!> PersistList  <$> readTextData input
       <!> PersistText  <$> return input
       where
@@ -433,6 +435,7 @@ fromPersistValueText (PersistText s) = Right s
 fromPersistValueText (PersistByteString bs) =
     Right $ TE.decodeUtf8With lenientDecode bs
 fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i
+fromPersistValueText (PersistWord64 w) = Right $ T.pack $ show w
 fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d
 fromPersistValueText (PersistRational r) = Right $ T.pack $ show r
 fromPersistValueText (PersistDay d) = Right $ T.pack $ show d
@@ -450,6 +453,7 @@ instance A.ToJSON PersistValue where
     toJSON (PersistText t) = A.String $ T.cons 's' t
     toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b
     toJSON (PersistInt64 i) = A.Number $ fromIntegral i
+    toJSON (PersistWord64 w) = A.Number $ fromIntegral w
     toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d
     toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r
     toJSON (PersistBool b) = A.Bool b
@@ -534,6 +538,7 @@ data SqlType = SqlString
              | SqlTime
              | SqlDayTime -- ^ Always uses UTC timezone
              | SqlBlob
+             | SqlWord64 -- @since 2.11.0
              | SqlOther T.Text -- ^ a backend-specific name
     deriving (Show, Read, Eq, Typeable, Ord)