From 2e1619f85176dcfa903835104d211cae28082e19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Wed, 15 May 2019 22:28:06 +0200 Subject: [PATCH] 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 | 25 ++++++++ Database/MySQL/Simple/QueryParams/Generic.hs | 27 +++++++++ Database/MySQL/Simple/QueryResults.hs | 60 +++++++++---------- Database/MySQL/Simple/QueryResults/Generic.hs | 57 ++++++++++++++++++ Database/MySQL/Simple/Result.hs | 27 ++++++++- mysql-simple.cabal | 6 +- 6 files changed, 170 insertions(+), 32 deletions(-) create mode 100644 Database/MySQL/Simple/QueryParams/Generic.hs create mode 100644 Database/MySQL/Simple/QueryResults/Generic.hs diff --git a/Database/MySQL/Simple/QueryParams.hs b/Database/MySQL/Simple/QueryParams.hs index eeb74b8..2966f15 100644 --- a/Database/MySQL/Simple/QueryParams.hs +++ b/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 _ = [] diff --git a/Database/MySQL/Simple/QueryParams/Generic.hs b/Database/MySQL/Simple/QueryParams/Generic.hs new file mode 100644 index 0000000..ea32b82 --- /dev/null +++ b/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 diff --git a/Database/MySQL/Simple/QueryResults.hs b/Database/MySQL/Simple/QueryResults.hs index d35366c..80c5497 100644 --- a/Database/MySQL/Simple/QueryResults.hs +++ 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,7 +70,18 @@ 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. @@ -75,6 +89,16 @@ class QueryResults a where -- 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 diff --git a/Database/MySQL/Simple/QueryResults/Generic.hs b/Database/MySQL/Simple/QueryResults/Generic.hs new file mode 100644 index 0000000..501888a --- /dev/null +++ b/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 diff --git a/Database/MySQL/Simple/Result.hs b/Database/MySQL/Simple/Result.hs index 16e117e..0102b0c 100644 --- a/Database/MySQL/Simple/Result.hs +++ b/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 diff --git a/mysql-simple.cabal b/mysql-simple.cabal index 6c6ff67..8c5222e 100644 --- a/mysql-simple.cabal +++ b/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,