diff --git a/oracle-simple.cabal b/oracle-simple.cabal index 090cb18..34b901a 100644 --- a/oracle-simple.cabal +++ b/oracle-simple.cabal @@ -23,7 +23,7 @@ executable tests main-is: Main.hs build-depends: - base < 5, oracle-simple, text, time, hspec, QuickCheck, quickcheck-instances + base < 5, ieee754, oracle-simple, text, time, hspec, QuickCheck, quickcheck-instances hs-source-dirs: test default-language: diff --git a/test/Main.hs b/test/Main.hs index e93e60f..514a3f1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,15 +1,24 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where -import Foreign.C.Types +import Control.Monad.IO.Class (liftIO) +import Data.AEq import Data.Fixed -import Control.Monad.IO.Class (liftIO) -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Test.QuickCheck.Instances () +import Data.Function +import Data.Int +import Data.Text (Text) import Data.Time +import Foreign.C.Types +import GHC.Generics import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck hiding ((===)) +import Test.QuickCheck.Instances () import Database.Oracle.Simple @@ -73,6 +82,58 @@ spec = do dpiTimeStampToUTCDPITimeStamp dpi `shouldBe` expected it "Should roundtrip UTCTime through DPITimestamp (w/ nanos -- not picos) " $ \_ -> do - property $ \tod day (nanos :: Nano) -> do - let utc = UTCTime day $ timeOfDayToTime tod { todSec = realToFrac nanos } + property $ \(UTCTimeNanos utc) -> do utc `shouldBe` dpiTimeStampToUTCTime (utcTimeToDPITimestamp utc) + + describe "Roundtrip tests" $ do + it "Should round trip random values from a table" $ \conn -> do + property $ \expected@TestTable{..} -> do + execute_ conn "create table test (a varchar(300), b number (12,0), c number (12,0), d number (12,0) null, e timestamp (9), f number (38,28))" + execute conn "insert into test values (:1,:2,:3,:4,:5,:6)" expected + actual <- query_ conn "select * from test" + execute_ conn "drop table test" + actual `shouldBe` [expected] + +data TestTable + = TestTable + { fieldText :: Text + , fieldInt :: Int + , fieldInt64 :: Int64 + , fieldMaybeInt :: Maybe Int + , fieldUTCTime :: UTCTimeNanos + , fieldDouble :: Double + } deriving stock (Generic, Show) + deriving anyclass (ToRow, FromRow) + +instance Eq TestTable where + x == y = + and + [ ((==) `on` fieldText) x y + , ((==) `on` fieldInt) x y + , ((==) `on` fieldInt64) x y + , ((==) `on` fieldMaybeInt) x y + , ((==) `on` fieldUTCTime) x y + , ((~==) `on` fieldDouble) x y + ] + +instance Arbitrary TestTable where + arbitrary = + TestTable + <$> arbitrary + <*> arbitrary -- choose (- 2^12, 2 ^ 12) + <*> arbitrary -- choose (- 2^12, 2 ^ 12) + <*> arbitrary -- oneof [ Just <$> choose (- 2^12, 2 ^ 12), pure Nothing ] + <*> arbitrary + <*> arbitrary + +newtype UTCTimeNanos = UTCTimeNanos UTCTime + deriving stock (Eq) + deriving newtype (Show, FromField, ToField, HasDPINativeType) + +instance Arbitrary UTCTimeNanos where + arbitrary = do + tod <- arbitrary + day <- arbitrary + nanos :: Nano <- arbitrary + let utcTime = UTCTime day $ timeOfDayToTime tod { todSec = realToFrac nanos } + pure (UTCTimeNanos utcTime)