Make sure fromRational can handle repeating fractions

circuithub · Feb 20, 2024 · fc56512 · fc56512
1 parent ca615ee
commit fc56512
Show file tree

Hide file tree

Showing 3 changed files with 37 additions and 5 deletions.
diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs
@@ -17,6 +17,7 @@ where
 
 -- base
 import Data.Functor.Identity ( Identity( Identity ) )
+import Data.Ratio (denominator, numerator)
 import Data.String ( IsString, fromString )
 import Prelude hiding ( null )
 
@@ -46,6 +47,9 @@ import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
 import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
 import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
 
+-- scientific
+import Data.Scientific (fromRationalRepetendLimited)
+
 
 -- | Typed SQL expressions.
 type Expr :: K.Context
@@ -89,8 +93,15 @@ instance Sql DBNum a => Num (Expr a) where
 instance Sql DBFractional a => Fractional (Expr a) where
   (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
 
-  fromRational =
-    castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
+  fromRational = castExpr . Expr . toScientific
+    where
+      toScientific r = case fromRationalRepetendLimited 20 r of
+        Right (s, Nothing) -> Opaleye.ConstExpr (Opaleye.NumericLit s)
+        _ -> Opaleye.BinExpr (Opaleye.:/) (int n) (int d)
+          where
+            int = Opaleye.ConstExpr . Opaleye.NumericLit . fromInteger
+            n = numerator r
+            d = denominator r
 
 
 instance Sql DBFloating a => Floating (Expr a) where

diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs
@@ -227,7 +227,7 @@ instance DBType Double where
 -- | Corresponds to @numeric@
 instance DBType Scientific where
   typeInformation = TypeInformation
-    { encode = Opaleye.ConstExpr . Opaleye.NumericLit 
+    { encode = Opaleye.ConstExpr . Opaleye.NumericLit
     , decode =
         Decoder
           { binary = Hasql.numeric
@@ -249,7 +249,7 @@ instance PowerOf10 n => DBType (Fixed n) where
           , parser = parse A.scientific
           , delimiter = ','
           }
-    , typeName =    
+    , typeName =
         TypeName
           { name = "numeric"
           , modifiers = ["1000", show (resolution @n)]

diff --git a/tests/Main.hs b/tests/Main.hs
@@ -30,6 +30,7 @@ import Data.Functor (void)
 import Data.Int ( Int32, Int64 )
 import Data.List ( nub, sort )
 import Data.Maybe ( catMaybes )
+import Data.Ratio ((%))
 import Data.String ( fromString )
 import Data.Word (Word32, Word8)
 import GHC.Generics ( Generic )
@@ -121,6 +122,7 @@ tests =
     , testDBType getTestDatabase
     , testDBEq getTestDatabase
     , testTableEquality getTestDatabase
+    , testFromRational getTestDatabase
     , testFromString getTestDatabase
     , testCatMaybeTable getTestDatabase
     , testCatMaybe getTestDatabase
@@ -608,8 +610,27 @@ testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
      eq === (x == y)
 
 
+testFromRational :: IO TmpPostgres.DB -> TestTree
+testFromRational = databasePropertyTest "fromRational" \transaction -> do
+  numerator <- forAll $ Gen.int64 Range.linearBounded
+  denominator <- forAll $ Gen.int64 $ Range.linear 1 maxBound
+
+  let
+    rational = toInteger numerator % toInteger denominator
+    double = fromRational @Double rational
+
+  transaction do
+    result <- lift do
+      statement () $ Rel8.run1 $ Rel8.select do
+        pure $ fromRational rational
+    diff result (~=) double
+  where
+    a ~= b = abs (a - b) < 1e-15
+    infix 4 ~=
+
+
 testFromString :: IO TmpPostgres.DB -> TestTree
-testFromString = databasePropertyTest "FromString" \transaction -> do
+testFromString = databasePropertyTest "fromString" \transaction -> do
   str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
 
   transaction do