From 6228c64b22ba62db530d5b84078a9093f5d76f4f Mon Sep 17 00:00:00 2001
From: David Johnson <djohnson.m@gmail.com>
Date: Sun, 24 Sep 2023 20:53:29 -0500
Subject: [PATCH 1/2] Add roundtrip tests for all common types

---
 oracle-simple.cabal |  2 +-
 test/Main.hs        | 75 ++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 69 insertions(+), 8 deletions(-)

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..6b3879f 100644
--- a/test/Main.hs
+++ b/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)

From 7be8d51646ad08ee177e6c276ae841c262fcbcd0 Mon Sep 17 00:00:00 2001
From: David Johnson <djohnson.m@gmail.com>
Date: Tue, 3 Oct 2023 08:41:01 -0500
Subject: [PATCH 2/2] Add timestamp(9) precision, use actual vs. expected.

---
 test/Main.hs | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/test/Main.hs b/test/Main.hs
index 6b3879f..514a3f1 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Main where
 
 import Control.Monad.IO.Class    (liftIO)
@@ -87,12 +87,12 @@ spec = do
 
     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"
+        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"
-          [x] `shouldBe` y
+          actual `shouldBe` [expected]
 
 data TestTable
   = TestTable