Allow Integral types to parse PersistRational

cabal.project

@@ -8,6 +8,10 @@ packages:
   persistent-redis
   persistent-qq
 
+constraints:
+  -- https://github.com/mongodb-haskell/mongodb/pull/152
+  mongoDB < 2.7.1.3 
+
 -- GHC 9.4 shims for persistent
 
 -- These need hackage revisions but otherwise test fine in the repo

persistent/ChangeLog.md

@@ -1,5 +1,12 @@
 # Changelog for persistent
 
+## 2.14.6.1
+
+* [#1528](https://github.com/yesodweb/persistent/pull/1528)
+    * The `PersistField Int{,8,16,32,64}` instances will now work with a
+      `PersistRational`, provided that the denominator is 1. This fixes the bug
+      where `SUM` in Postgres would change the type of a column being summed.
+
 ## 2.14.6.0
 
 * [#1477](https://github.com/yesodweb/persistent/pull/1477)

persistent/Database/Persist/Class/PersistField.hs

@@ -33,6 +33,7 @@ import Numeric.Natural (Natural)
 import Text.Blaze.Html
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 import GHC.TypeLits
+import Data.Ratio (numerator, denominator)
 
 import Database.Persist.Types.Base
 
@@ -135,49 +136,49 @@ instance PersistField Html where
 
 instance PersistField Int where
     toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i)  = Right $ fromIntegral i
-    fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle
-    fromPersistValue x = Left $ fromPersistValueError "Int" "integer" x
+    fromPersistValue = fromPersistValueIntegral "Int" "integer"
 
 instance PersistField Int8 where
     toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i)  = Right $ fromIntegral i
-    fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle
-    fromPersistValue (PersistByteString bs) = case readInt bs of  -- oracle
-                                               Just (i,"") -> Right $ fromIntegral i
-                                               Just (i,extra) -> Left $ extraInputError "Int64" bs i extra
-                                               Nothing -> Left $ intParseError "Int64" bs
-    fromPersistValue x = Left $ fromPersistValueError "Int8" "integer" x
+    fromPersistValue = fromPersistValueIntegral "Int8" "integer"
 
 instance PersistField Int16 where
     toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i)  = Right $ fromIntegral i
-    fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle
-    fromPersistValue (PersistByteString bs) = case readInt bs of  -- oracle
-                                               Just (i,"") -> Right $ fromIntegral i
-                                               Just (i,extra) -> Left $ extraInputError "Int64" bs i extra
-                                               Nothing -> Left $ intParseError "Int64" bs
-    fromPersistValue x = Left $ fromPersistValueError "Int16" "integer" x
+    fromPersistValue = fromPersistValueIntegral "Int16" "integer"
 
 instance PersistField Int32 where
     toPersistValue = PersistInt64 . fromIntegral
-    fromPersistValue (PersistInt64 i)  = Right $ fromIntegral i
-    fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle
-    fromPersistValue (PersistByteString bs) = case readInt bs of  -- oracle
-                                               Just (i,"") -> Right $ fromIntegral i
-                                               Just (i,extra) -> Left $ extraInputError "Int64" bs i extra
-                                               Nothing -> Left $ intParseError "Int64" bs
-    fromPersistValue x = Left $ fromPersistValueError "Int32" "integer" x
+    fromPersistValue = fromPersistValueIntegral "Int32" "integer"
 
 instance PersistField Int64 where
     toPersistValue = PersistInt64
-    fromPersistValue (PersistInt64 i)  = Right i
-    fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle
-    fromPersistValue (PersistByteString bs) = case readInt bs of  -- oracle
-                                               Just (i,"") -> Right $ fromIntegral i
-                                               Just (i,extra) -> Left $ extraInputError "Int64" bs i extra
-                                               Nothing -> Left $ intParseError "Int64" bs
-    fromPersistValue x = Left $ fromPersistValueError "Int64" "integer" x
+    fromPersistValue = fromPersistValueIntegral "Int64" "integer"
+
+fromPersistValueIntegral :: Integral a => Text -> Text -> PersistValue -> Either Text a
+fromPersistValueIntegral haskellType sqlType pv = case pv of
+    PersistInt64 i ->
+        Right (fromIntegral i)
+    PersistDouble i ->
+        Right $ truncate i -- oracle
+    PersistRational i ->
+        case denominator i of
+            1 ->
+                Right $ fromIntegral $ numerator i
+            _denom ->
+                boom
+    PersistByteString bs ->
+        case readInt bs of  -- oracle
+           Just (i,"") ->
+               Right $ fromIntegral i
+           Just (i,extra) ->
+               Left $ extraInputError haskellType bs i extra
+           Nothing ->
+               Left $ intParseError haskellType bs
+    _ ->
+        boom
+  where
+    boom =
+        Left $ fromPersistValueError haskellType sqlType pv
 
 extraInputError :: (Show result)
                 => Text -- ^ Haskell type

persistent/persistent.cabal

@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.14.6.0
+version:         2.14.6.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <[email protected]>

stack.yaml

@@ -9,3 +9,6 @@ packages:
   - ./persistent-postgresql
   - ./persistent-redis
   - ./persistent-qq
+
+extra-deps:
+  - attoparsec-aeson-2.1.0.0