From 8ca2778b05bec97d6684cfa94a44d9ca2e9a36b8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= <fhi.1990@gmail.com>
Date: Thu, 30 May 2019 13:17:21 +0200
Subject: [PATCH] Add test-case for generic implementation of QueryResults

---
 Database/MySQL/Simple/QueryResults/Generic.hs |  4 +-
 mysql-simple.cabal                            |  2 +
 test/main.hs                                  | 63 +++++++++++++++++--
 3 files changed, 61 insertions(+), 8 deletions(-)

diff --git a/Database/MySQL/Simple/QueryResults/Generic.hs b/Database/MySQL/Simple/QueryResults/Generic.hs
index a456ef1..c8bcef7 100644
--- a/Database/MySQL/Simple/QueryResults/Generic.hs
+++ b/Database/MySQL/Simple/QueryResults/Generic.hs
@@ -65,8 +65,8 @@ instance QueryResults U1 where
     _  -> throw err
 
 instance Result a => QueryResults (K1 i a) where
-  convertResults err xs ys = case zip xs ys of
-    [(x, y)] -> K1 $ Result.convert x y
+  convertResults err xs ys = case zipWith Result.convert xs ys of
+    [res] -> K1 res
     _ -> throw err
 
 instance QueryResults a => QueryResults (M1 i c a) where
diff --git a/mysql-simple.cabal b/mysql-simple.cabal
index 092f612..a2ec75e 100644
--- a/mysql-simple.cabal
+++ b/mysql-simple.cabal
@@ -85,6 +85,8 @@ test-suite test
                    , hspec
                    , mysql-simple
                    , text
+                   , mysql
+                   , bytestring
 
 source-repository head
   type:     git
diff --git a/test/main.hs b/test/main.hs
index 4def253..6758f3d 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -1,16 +1,22 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving,
+  DerivingStrategies, DeriveGeneric, DeriveAnyClass, RankNTypes #-}
 
-import Control.Exception (bracket)
 import Data.Text (Text)
 import Database.MySQL.Simple
 import Database.MySQL.Simple.Param
+import Database.MySQL.Base.Types (Field(Field), Type(Tiny))
 import Test.Hspec
+import qualified Data.ByteString.Char8 as ByteString
 import Blaze.ByteString.Builder (toByteString)
 #if MIN_VERSION_base(4,8,2)
 #else
 import Control.Applicative
 import Data.Monoid
 #endif
+import GHC.Generics
+import Database.MySQL.Simple.QueryResults
+import Data.Int (Int8)
+import Control.Monad (void)
 
 -- This is how to connect to our test database
 testConn :: ConnectInfo
@@ -22,10 +28,27 @@ testConn = defaultConnectInfo {
 
 main :: IO ()
 main =
-  bracket (connect testConn) close $ \conn ->
-    hspec $ do
-      unitSpec
-      integrationSpec conn
+  hspec $ do
+    unitSpec
+    genericQueryResultsSpec
+    bracket' runIO (connect testConn) close integrationSpec
+
+-- | Ad-hoc lifted version of 'bracket'.  The typical 'liftIO' method
+-- is a parameter to this function rather than a constraint since
+-- 'SpecM' from "Test.Hspec.Core.Spec" is not an instance of
+-- 'MonadIO'.
+bracket'
+  :: Monad io
+  => (forall x . IO x -> io x)
+  -> IO a
+  -> (a -> IO b)
+  -> (a -> io b)
+  -> io b
+bracket' liftIO' acq rel act = do
+  conn <- liftIO' acq
+  a <- act conn
+  void $ liftIO' $ rel conn
+  pure a
 
 unitSpec :: Spec
 unitSpec = do
@@ -52,3 +75,31 @@ integrationSpec conn = do
     it "can connect to a database" $ do
       result <- query_ conn "select 1 + 1"
       result `shouldBe` [Only (2::Int)]
+
+data U = U Int8 Int8 Int8
+
+deriving stock    instance Eq U
+deriving stock    instance Generic U
+deriving stock    instance Show U
+deriving anyclass instance QueryResults U
+
+data T = T Int8 Int8 Int8 Int8 Int8 Int8
+
+deriving stock    instance Eq T
+deriving stock    instance Generic T
+deriving stock    instance Show T
+deriving anyclass instance QueryResults T
+
+genericQueryResultsSpec :: Spec
+genericQueryResultsSpec =
+  describe "QueryResults" $
+    it "can perform generic conversions" $ do
+      convert [0..2] `shouldBe` U 0 1 2
+      convert [0..5] `shouldBe` T 0 1 2 3 4 5
+  where
+  aField :: Field
+  aField = Field mempty mempty mempty mempty
+    mempty mempty mempty 0 0 mempty 0 0 Tiny
+  convert :: QueryResults a => [Int8] -> a
+  convert xs = convertResults
+    (replicate 3 aField) $ Just . ByteString.pack . show <$> xs