Add roundtrip tests for all common types

Author: dmjio

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:

test/Main.hs

@@ -1,15 +1,24 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 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 $ \x@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, f number (38,28))"
+          execute conn "insert into test values (:1,:2,:3,:4,:5,:6)" x
+          y  <- query_ conn "select * from test"
+          execute_ conn "drop table test"
+          [x] `shouldBe` y
+
+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)