mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-03 20:32:28 +03:00
Make sure fromRational
can handle repeating fractions (#309)
This commit is contained in:
parent
ca615eeddf
commit
95df13f6e5
@ -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
|
||||
|
@ -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)]
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user