Upgrade LTS, generic derivations, SQL quasi quoter

Database/MySQL/Simple/Arity.hs

@@ -0,0 +1,49 @@
+{-| Generic calculation of the "arity" of data-types.
+
+This code was originally written by Li-yao Xia. See
+<https://stackoverflow.com/a/56351505/1021134>.
+-}
+{-# LANGUAGE
+    AllowAmbiguousTypes
+  , ScopedTypeVariables
+  , TypeFamilies
+  , UndecidableInstances
+  , FlexibleContexts
+  , DataKinds
+  , TypeOperators
+#-}
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Database.MySQL.Simple.Arity
+  ( Arity
+  , arity
+  , KnownNat
+  ) where
+
+import Data.Kind (Type)
+import Data.Proxy (Proxy(Proxy))
+import Numeric.Natural (Natural)
+import GHC.Generics (M1, U1, K1, (:*:), Generic, Rep)
+import GHC.TypeNats (KnownNat, Nat, type (+), natVal)
+
+type family Arity (f :: Type -> Type) :: Nat
+type instance Arity (M1 _ _ f) = Arity f
+type instance Arity (f :*: g) = Arity f + Arity g
+type instance Arity U1 = 0
+type instance Arity (K1 i a) = 1
+
+-- We need the proxy argument to support GHC version prior to the
+-- introduction of '-XTypeApplications'.
+-- | @'arity' (Proxy :: a)@ for some type @a@ calculates the arity of
+-- its only constructor.  @a@ *must* be a type with a single
+-- constructor that has @n@ fields.
+arity
+  :: forall a
+  .  Generic a
+  => KnownNat (Arity (Rep a))
+  => Proxy a
+  -> Natural
+arity _ = natVal p
+  where
+  p :: Proxy (Arity (Rep a))
+  p = Proxy

Database/MySQL/Simple/Compat.hs

@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Database.MySQL.Simple.Compat
+  ( module X
+  ) where
+
+import Data.Semigroup as X (Semigroup(..))
+import Data.String as X (fromString)

Database/MySQL/Simple/Prelude.hs

@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Database.MySQL.Simple.Prelude
+  ( module X
+  ) where
+
+import Prelude as X
+import Database.MySQL.Simple.Compat as X

Database/MySQL/Simple/QQ.hs

@@ -0,0 +1,49 @@
+{-| A quasi-quoter for SQL expressions. -}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Database.MySQL.Simple.QQ
+  ( sql
+  ) where
+
+import Prelude ()
+import Database.MySQL.Simple.Prelude
+import Language.Haskell.TH          (Exp, Q, appE, stringE)
+import Language.Haskell.TH.Quote    (QuasiQuoter (..))
+import Database.MySQL.Simple        (Query, Query)
+import Text.Printf                  (printf)
+
+-- | A quasi-quoter for SQL expressions.
+--
+-- The quasi-quoter does not do any sort of parsing of the SQL.  It's
+-- simply a convenience for writing multi-line SQL statements.  So in stead of:
+--
+-- > query
+-- >   =  "select * "
+-- >   <> "from users "
+-- >   <> "where email is null;"
+--
+-- You could write
+--
+-- > query = [sql|
+-- >   select *
+-- >   from users
+-- >   where email is null;
+-- > |]
+--
+-- Note the quasi-quoter is only valid in expression contexts.
+--
+-- @since 0.4.7
+sql :: QuasiQuoter
+sql = QuasiQuoter
+  { quotePat  = err "pattern"
+  , quoteType = error "Database.MySQL.Simple.QQ.sql: quasiquoter used in type context"
+  , quoteDec  = error "Database.MySQL.Simple.QQ.sql: quasiquoter used in declaration context"
+  , quoteExp  = quote
+  }
+  where
+  err :: String -> a
+  err ctxt = error (printf "Database.MySQL.Simple.QQ.sql: quasiquoter used in %s context" ctxt)
+
+quote :: String -> Q Exp
+quote = appE [| fromString :: String -> Query |] . stringE

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,30 @@
+{-| Generic deriviation of 'Database.MySQL.Simple.QueryParams.QueryParams'. -}
+{-# LANGUAGE ScopedTypeVariables, TypeOperators, InstanceSigs #-}
+{-# OPTIONS_GHC -Wall -Werror #-}
+module Database.MySQL.Simple.QueryParams.Generic
+  ( QueryParams(..)
+  ) where
+
+import Prelude ()
+import Database.MySQL.Simple.Prelude
+import GHC.Generics
+
+import Database.MySQL.Simple.Param (Action(..), Param(..))
+
+class QueryParams f 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 Database.MySQL.Simple.Arity (Arity, KnownNat)
+import GHC.Generics (Generic, Rep)
 
 -- | 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
+        -- Used for for error messages.
+        => KnownNat (Arity (Rep a))
+        => Generic.QueryResults (Rep a)
+        => [Field]
+        -> [Maybe ByteString]
+        -> a
+    convertResults = Generic.convert
+
 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,88 @@
+{-| Generic deriviation of 'Database.MySQL.Simple.QueryResults.QueryResults'. -}
+{-# LANGUAGE
+    ScopedTypeVariables
+  , TypeOperators
+  , InstanceSigs
+  , FlexibleContexts
+  , AllowAmbiguousTypes
+  #-}
+{-# OPTIONS_GHC -Wall -Werror #-}
+
+module Database.MySQL.Simple.QueryResults.Generic
+  ( QueryResults(..)
+  , convert
+  ) where
+
+import Prelude ()
+import Database.MySQL.Simple.Prelude
+import Data.ByteString (ByteString)
+import GHC.Generics
+import qualified GHC.Generics as Generics
+import Control.Exception (throw)
+
+import Database.MySQL.Base.Types (Field)
+import Database.MySQL.Simple.Result
+  (Result, ResultError)
+import qualified Database.MySQL.Simple.Result as Result
+import Data.Proxy (Proxy(Proxy))
+import Database.MySQL.Simple.Arity (Arity, arity, KnownNat)
+
+-- | Generic implementation of
+-- 'Database.MySQL.Simple.QueryResults.Generic.convertResults'.
+convert
+  :: forall a
+  .  Generic a
+  => KnownNat (Arity (Rep a))
+  => QueryResults (Rep a)
+  => [Field]
+  -> [Maybe ByteString]
+  -> a
+convert xs ys = Generics.to $ convertResults err xs ys
+  where
+  err = Result.convertException xs ys $ fromIntegral $ arity (Proxy :: Proxy a)
+
+-- | The generic counterpart to 'Database.MySQL.Simple.QueryResults.QueryResults'.
+class QueryResults f where
+  convertResults :: ResultError -> [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 err xs ys = case zip xs ys of
+    [] -> U1
+    _  -> 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
+    _ -> throw err
+
+instance QueryResults a => QueryResults (M1 i c a) where
+  convertResults err xs ys =
+    M1 $ convertResults err xs ys
+
+instance (QueryResults a, QueryResults b) => QueryResults (a :*: b) where
+  convertResults
+    :: forall x
+    .  ResultError
+    -> [Field]
+    -> [Maybe ByteString]
+    -> (:*:) a b x
+  convertResults err (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 err [x] [y] :*: convertResults err xs ys
+  convertResults err _ _ = throw err