Implement generic derivations for QueryParams and QueryResults

I moved `convertError` from `Database.MySQL.Simpe.QueryResults` into
`Database.MySQL.Simple.Result` to avoid a cyclic dependency between
the `Database.MySQL.Simpe.QueryResults` and
`Database.MySQL.Simpe.QueryResults.Generic` that both make use of said
function.

Note that this change requires GHC Haskell.  We may want to hide this
behind a preprocessor flag for that reason.

I don't quite know if it makes sense to derive instances for
`U1` (types with a single constructor and no fields).  Although it is
certainly helpful during development to not get a type error when
trying to derive instances for a type that you are in the process of
defining, like:

    data User = User

I have also noted a concern with my generic implementation for
`(:*:)`.  I'll reproduce it here:

I'm concerned about this implementation since it's biased
towards one side.  Meaning that it's expecting the chain of
`(:*:)` to lean to the right.  As an example of the problem
consider the following:

    > data T = T Int Int Int deriving (Generic)
    > from (T 1 2 3)
    M1 {unM1 = M1 {unM1 = M1 {unM1 = K1 {unK1 = 1}} :*: (M1 {unM1 = K1 {unK1 = 2}} :*: M1 {unM1 = K1 {unK1 = 3}})}}

If the result in stead had been like this (note the re-bracketing):

    M1 {unM1 = (M1 {unM1 = M1 {unM1 = K1 {unK1 = 1}} :*: M1 {unM1 = K1 {unK1 = 2}}}) :*: M1 {unM1 = K1 {unK1 = 3}}}

Then the generic derivation for `T` would fail.

Furthermore, to be able to supply the arity in the call to
`convertError` I think we might need a `Typeable (a :*: b)`
constraint.

Lastly, the existing implementations for `QueryResults` uses
strictness annotations in certain places.  I don't know if these are
strictly (pun!) necessary and haven't used them in the generic
implementation.

Database/MySQL/Simple/QueryParams.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DefaultSignatures, FlexibleContexts #-}
 -- |
 -- Module:      Database.MySQL.Simple.QueryParams
 -- Copyright:   (c) 2011 MailRank, Inc.
@@ -19,16 +20,40 @@ module Database.MySQL.Simple.QueryParams
 
 import Database.MySQL.Simple.Param (Action(..), Param(..))
 import Database.MySQL.Simple.Types (Only(..))
+import qualified Database.MySQL.Simple.QueryParams.Generic as Generic
+import GHC.Generics (Generic, Rep)
+import GHC.Generics as Generics
 
 -- | A collection type that can be turned into a list of rendering
 -- 'Action's.
 --
 -- Instances should use the 'render' method of the 'Param' class
 -- to perform conversion of each element of the collection.
+--
+-- === Generic derivation
+--
+-- Since version 0.4.6 it's possible to generically derive instances
+-- for some types.  One conditition is that the type must only have a
+-- single constructor.  In those cases an instance can derived thus:
+--
+-- @
+-- deriving anyclass instance 'QueryParams' User
+-- @
+--
+-- This requires @-XDeriveAnyClass@ and @-XDerivingStrategies@.  Here
+-- @User@ is the example from
+-- 'Database.MySQL.Simple.QueryResults.QueryResults'.
 class QueryParams a where
     renderParams :: a -> [Action]
     -- ^ Render a collection of values.
 
+    default renderParams
+        :: Generic a
+        => Generic.QueryParams (Rep a)
+        => a
+        -> [Action]
+    renderParams = Generic.renderParams . Generics.from
+
 instance QueryParams () where
     renderParams _ = []
 

Database/MySQL/Simple/QueryParams/Generic.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE ScopedTypeVariables, TypeOperators, InstanceSigs, KindSignatures #-}
+module Database.MySQL.Simple.QueryParams.Generic
+  ( QueryParams(..)
+  ) where
+
+import Data.Kind
+import GHC.Generics
+
+import Database.MySQL.Simple.Param (Action(..), Param(..))
+
+class QueryParams (f :: Type -> Type) where
+  renderParams :: f a -> [Action]
+
+-- This instance might not make sense, though the signature of
+-- 'renderParams' sort of implies that it does since it returns a
+-- '[]''s in stead of a 'NonEmpty''s.
+instance QueryParams U1 where
+  renderParams = const mempty
+
+instance Param a => QueryParams (K1 i a) where
+  renderParams (K1 a) = pure $ render a
+
+instance QueryParams a => QueryParams (M1 i c a) where
+  renderParams (M1 a) = renderParams a
+
+instance (QueryParams a, QueryParams b) => QueryParams (a :*: b) where
+  renderParams (a :*: b) = renderParams a <> renderParams b

Database/MySQL/Simple/QueryResults.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE BangPatterns, OverloadedStrings #-}
+{-# LANGUAGE BangPatterns, OverloadedStrings, DefaultSignatures,
+  FlexibleContexts #-}
 
 -- |
 -- Module:      Database.MySQL.Simpe.QueryResults
@@ -20,12 +21,14 @@ module Database.MySQL.Simple.QueryResults
     , convertError
     ) where
 
-import Control.Exception (throw)
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import Database.MySQL.Base.Types (Field(fieldType, fieldName))
-import Database.MySQL.Simple.Result (ResultError(..), Result(..))
+import Database.MySQL.Base.Types (Field)
+import Database.MySQL.Simple.Result (Result(..), convertError)
+
 import Database.MySQL.Simple.Types (Only(..))
+import qualified Database.MySQL.Simple.QueryResults.Generic as Generic
+import GHC.Generics (Generic, Rep)
+import qualified GHC.Generics as Generics
 
 -- | A collection type that can be converted from a list of strings.
 --
@@ -67,14 +70,35 @@ import Database.MySQL.Simple.Types (Only(..))
 --              !b = 'convert' fb vb
 --    'convertResults' fs vs  = 'convertError' fs vs 2
 -- @
-
+--
+-- === Generic derivation
+--
+-- Since version 0.4.6 it's possible to generically derive instances
+-- for some types.  One conditition is that the type must only have a
+-- single constructor.  In those cases an instance can derived thus:
+--
+-- @
+-- deriving anyclass instance 'QueryResults' User
+-- @
+--
+-- This requires @-XDeriveAnyClass@ and @-XDerivingStrategies@.
 class QueryResults a where
     convertResults :: [Field] -> [Maybe ByteString] -> a
     -- ^ Convert values from a row into a Haskell collection.
     --
     -- This function will throw a 'ResultError' if conversion of the
     -- collection fails.
 
+    default convertResults
+        :: Generic a
+        => Generic.QueryResults (Rep a)
+        => [Field]
+        -> [Maybe ByteString]
+        -> a
+    convertResults xs ys
+        = Generics.to
+        $ Generic.convertResults xs ys
+
 instance (Result a) => QueryResults (Only a) where
     convertResults [fa] [va] = Only a
         where !a = convert fa va
@@ -378,27 +402,3 @@ instance (Result a, Result b, Result c, Result d, Result e, Result f,
               !s = convert fs vs; !t = convert ft vt; !u = convert fu vu
               !v = convert fv vv; !w = convert fw vw; !x = convert fx vx;
     convertResults fs_ vs_  = convertError fs_ vs_ 24
-
--- | Throw a 'ConversionFailed' exception, indicating a mismatch
--- between the number of columns in the 'Field' and row, and the
--- number in the collection to be converted to.
-convertError :: [Field]
-             -- ^ Descriptors of fields to be converted.
-             -> [Maybe ByteString]
-             -- ^ Contents of the row to be converted.
-             -> Int
-             -- ^ Number of columns expected for conversion.  For
-             -- instance, if converting to a 3-tuple, the number to
-             -- provide here would be 3.
-             -> a
-convertError fs vs n = throw $ ConversionFailed
-    (show (length fs) ++ " values: " ++ show (zip (map fieldType fs)
-                                                  (map (fmap ellipsis) vs)))
-    (show n ++ " slots in target type")
-    (show (map (B.unpack . fieldName) fs))
-    "mismatch between number of columns to convert and number in target type"
-
-ellipsis :: ByteString -> ByteString
-ellipsis bs
-    | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
-    | otherwise        = bs

Database/MySQL/Simple/QueryResults/Generic.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE ScopedTypeVariables, TypeOperators, InstanceSigs, KindSignatures #-}
+module Database.MySQL.Simple.QueryResults.Generic
+  ( QueryResults(..)
+  ) where
+
+import Prelude
+import Data.Kind
+import Data.ByteString (ByteString)
+import GHC.Generics
+
+import Database.MySQL.Base.Types (Field)
+import Database.MySQL.Simple.Result (Result(convert), convertError)
+
+class QueryResults (f :: Type -> Type) where
+  convertResults :: [Field] -> [Maybe ByteString] -> (f a)
+
+-- This instance might not make sense, though the signature of
+-- 'convertResults' sort of implies that it does since it takes in two
+-- '[]''s in stead of two 'NonEmpty''s.
+instance QueryResults U1 where
+  convertResults xs ys = case zip xs ys of
+    [] -> U1
+    _  -> convertError xs ys 0
+
+instance Result a => QueryResults (K1 i a) where
+  convertResults xs ys = case zip xs ys of
+    [(x, y)] -> K1 $ convert x y
+    _ -> convertError xs ys 1
+
+instance QueryResults a => QueryResults (M1 i c a) where
+  convertResults xs ys =
+    M1 $ convertResults xs ys
+
+instance (QueryResults a, QueryResults b) => QueryResults (a :*: b) where
+  convertResults :: forall x . [Field] -> [Maybe ByteString] -> (:*:) a b x
+  convertResults (x:xs) (y:ys) =
+    -- I'm concerned about this implementation since it's biased
+    -- towards one side.  Meaning that it's expecting the chain of
+    -- ':*:' to lean to the right.  As an example of the problem
+    -- consider the following:
+    --
+    --     > data T = T Int Int Int deriving (Generic)
+    --     > from (T 1 2 3)
+    --     M1 {unM1 = M1 {unM1 = M1 {unM1 = K1 {unK1 = 1}} :*: (M1 {unM1 = K1 {unK1 = 2}} :*: M1 {unM1 = K1 {unK1 = 3}})}}
+    --
+    -- If the result in stead had been like this (note the re-bracketing):
+    --
+    --     M1 {unM1 = (M1 {unM1 = M1 {unM1 = K1 {unK1 = 1}} :*: M1 {unM1 = K1 {unK1 = 2}}}) :*: M1 {unM1 = K1 {unK1 = 3}}}
+    --
+    -- Then the generic derivation for 'T' would fail.
+    convertResults [x] [y] :*: convertResults xs ys
+  convertResults xs ys = convertError xs ys c
+    where
+    -- My guess is that we'd need @Typeable (a :*: b)@ to determine
+    -- the number of constructors we're expecting here.
+    c :: Int
+    c = -1

Database/MySQL/Simple/Result.hs

@@ -25,6 +25,7 @@ module Database.MySQL.Simple.Result
     (
       Result(..)
     , ResultError(..)
+    , convertError
     ) where
 
 #include "MachDeps.h"
@@ -40,7 +41,7 @@ import Data.Ratio (Ratio)
 import Data.Time.Calendar (Day, fromGregorian)
 import Data.Time.Clock (UTCTime(..))
 import Data.Time.Format (parseTime)
-import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)
+import Data.Time.LocalTime (TimeOfDay)
 import Data.Typeable (TypeRep, Typeable, typeOf)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Database.MySQL.Base.Types (Field(..), Type(..))
@@ -246,3 +247,27 @@ atto types p0 f = doConvert f types $ go undefined p0
         case parseOnly p s of
           Left err -> conversionFailed f (show (typeOf dummy)) err
           Right v  -> v
+
+-- | Throw a 'ConversionFailed' exception, indicating a mismatch
+-- between the number of columns in the 'Field' and row, and the
+-- number in the collection to be converted to.
+convertError :: [Field]
+             -- ^ Descriptors of fields to be converted.
+             -> [Maybe ByteString]
+             -- ^ Contents of the row to be converted.
+             -> Int
+             -- ^ Number of columns expected for conversion.  For
+             -- instance, if converting to a 3-tuple, the number to
+             -- provide here would be 3.
+             -> a
+convertError fs vs n = throw $ ConversionFailed
+    (show (length fs) ++ " values: " ++ show (zip (map fieldType fs)
+                                                  (map (fmap ellipsis) vs)))
+    (show n ++ " slots in target type")
+    (show (map (SB.unpack . fieldName) fs))
+    "mismatch between number of columns to convert and number in target type"
+
+ellipsis :: ByteString -> ByteString
+ellipsis bs
+    | SB.length bs > 15 = SB.take 10 bs `SB.append` "[...]"
+    | otherwise         = bs

mysql-simple.cabal

@@ -1,5 +1,5 @@
 name:           mysql-simple
-version:        0.4.5
+version:        0.4.6
 homepage:       https://github.com/paul-rouse/mysql-simple
 bug-reports:    https://github.com/paul-rouse/mysql-simple/issues
 synopsis:       A mid-level MySQL client library.
@@ -41,6 +41,10 @@ library
     Database.MySQL.Simple.Result
     Database.MySQL.Simple.Types
 
+  other-modules:
+    Database.MySQL.Simple.QueryParams.Generic
+    Database.MySQL.Simple.QueryResults.Generic
+
   build-depends:
     attoparsec >= 0.10.0.0,
     base < 5,