diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs index e52dc1b..6050017 100644 --- a/Database/SQLite/Simple/FromField.hs +++ b/Database/SQLite/Simple/FromField.hs @@ -34,13 +34,12 @@ module Database.SQLite.Simple.FromField , returnError ) where -import Control.Applicative (Applicative, (<$>), pure) import Control.Exception (SomeException(..), Exception) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Int (Int8, Int16, Int32, Int64) -import Data.Time (UTCTime, Day) +import Data.Time (UTCTime, Day, NominalDiffTime) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable, typeOf) @@ -186,6 +185,12 @@ instance FromField UTCTime where fromField f = returnError ConversionFailed f "expecting SQLText column type" +instance FromField NominalDiffTime where + fromField fld = case fieldData fld of + (SQLFloat n) -> pure $ realToFrac n + _ -> err "expecting SQLInteger column type" + where + err = returnError ConversionFailed fld instance FromField Day where fromField f@(Field (SQLText t) _) = diff --git a/Database/SQLite/Simple/FromRow.hs b/Database/SQLite/Simple/FromRow.hs index 781e8c1..297c77a 100644 --- a/Database/SQLite/Simple/FromRow.hs +++ b/Database/SQLite/Simple/FromRow.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, DefaultSignatures, FlexibleContexts, + StandaloneDeriving #-} ------------------------------------------------------------------------------ -- | @@ -17,7 +18,8 @@ ------------------------------------------------------------------------------ module Database.SQLite.Simple.FromRow - ( FromRow(..) + ( GFromRow(..) + , FromRow(..) , RowParser , field , fieldWith @@ -30,19 +32,53 @@ import Control.Monad (replicateM) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import GHC.Generics import Database.SQLite.Simple.FromField import Database.SQLite.Simple.Internal import Database.SQLite.Simple.Ok import Database.SQLite.Simple.Types + +-- | Generic derivation of 'FromRow'. +-- +-- Instantiating 'FromRow' can in some cases be quite tedious. Luckily +-- we can derive it generically in some cases where the type at hand +-- has a 'Generic' instance. The current implementation only works +-- for a (n-ary) product types. So we would not be able to +-- e.g. derive a 'FromRow' instance for +-- +-- @ +-- data Bool = True | False +-- @ +-- +-- We /can/, however, derive a generic instance for the @User@ type +-- (see the example in 'FromRow'). +-- +-- @since 0.4.16.1 +class GFromRow f where + gfromRow :: RowParser (f a) + +instance GFromRow U1 where + gfromRow = pure U1 + +instance FromField a => GFromRow (K1 i a) where + gfromRow = K1 <$> field + +instance GFromRow a => GFromRow (M1 i c a) where + gfromRow = M1 <$> gfromRow + +instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where + gfromRow = (:*:) <$> gfromRow <*> gfromRow + -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. -- -- Note that instances can defined outside of sqlite-simple, which is -- often useful. For example, here's an instance for a user-defined pair: -- --- @data User = User { name :: String, fileQuota :: Int } +-- @ +-- data User = User { name :: String, fileQuota :: Int } -- -- instance 'FromRow' User where -- fromRow = User \<$\> 'field' \<*\> 'field' @@ -54,10 +90,30 @@ import Database.SQLite.Simple.Types -- -- Note the caveats associated with user-defined implementations of -- 'fromRow'. - +-- +-- === Generic implementation +-- +-- Since version 0.4.16.1 it is possible in some cases to derive a +-- generic implementation for 'FromRow'. With a 'Generic' instance +-- for @User@, the example above could be written: +-- +-- @ +-- instance 'FromRow' User where +-- @ +-- +-- With @-XDeriveAnyClass -XDerivingStrategies@ the same can be written: +-- +-- @ +-- deriving anyclass instance 'FromRow' User +-- @ +-- +-- For more details refer to 'GFromRow'. class FromRow a where fromRow :: RowParser a + default fromRow :: Generic a => GFromRow (Rep a) => RowParser a + fromRow = to <$> gfromRow + fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do ncols <- asks nColumns diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs index 194f383..c76b72e 100644 --- a/Database/SQLite/Simple/ToField.hs +++ b/Database/SQLite/Simple/ToField.hs @@ -25,7 +25,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Encoding as T -import Data.Time (Day, UTCTime) +import Data.Time (Day, UTCTime, NominalDiffTime) import Data.Word (Word, Word8, Word16, Word32, Word64) import GHC.Float @@ -130,6 +130,9 @@ instance ToField LT.Text where instance ToField UTCTime where toField = SQLText . T.decodeUtf8 . toByteString . utcTimeToBuilder + +instance ToField NominalDiffTime where + toField = SQLFloat . realToFrac {-# INLINE toField #-} instance ToField Day where diff --git a/Database/SQLite/Simple/ToRow.hs b/Database/SQLite/Simple/ToRow.hs index 60e07f3..6e3e3e1 100644 --- a/Database/SQLite/Simple/ToRow.hs +++ b/Database/SQLite/Simple/ToRow.hs @@ -1,3 +1,5 @@ +{-# Language DefaultSignatures, FlexibleContexts, DeriveAnyClass, + StandaloneDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.SQLite.Simple.ToRow @@ -17,52 +19,58 @@ ------------------------------------------------------------------------------ module Database.SQLite.Simple.ToRow - ( - ToRow(..) + ( GToRow(..) + , ToRow(..) ) where +import GHC.Generics + import Database.SQLite.Simple.ToField (ToField(..)) import Database.SQLite.Simple.Types (Only(..), (:.)(..)) import Database.SQLite3 (SQLData(..)) --- | A collection type that can be turned into a list of 'SQLData' --- elements. -class ToRow a where - toRow :: a -> [SQLData] - -- ^ 'ToField' a collection of values. - -instance ToRow () where - toRow _ = [] - -instance (ToField a) => ToRow (Only a) where - toRow (Only v) = [toField v] +-- | Generic derivation of 'ToRow'. For details about what can be +-- derived refer to 'Database.Sqlite.Simple.FromRow.GFromRow'. +-- +-- @since 0.4.16.1 +class GToRow f where + gtoRow :: (f a) -> [SQLData] -instance (ToField a, ToField b) => ToRow (a,b) where - toRow (a,b) = [toField a, toField b] +instance GToRow U1 where + gtoRow U1 = toRow () -instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where - toRow (a,b,c) = [toField a, toField b, toField c] +instance ToField a => GToRow (K1 i a) where + gtoRow (K1 a) = pure $ toField a -instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where - toRow (a,b,c,d) = [toField a, toField b, toField c, toField d] +instance (GToRow a, GToRow b) => GToRow (a :*: b) where + gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b -instance (ToField a, ToField b, ToField c, ToField d, ToField e) - => ToRow (a,b,c,d,e) where - toRow (a,b,c,d,e) = - [toField a, toField b, toField c, toField d, toField e] +instance GToRow a => GToRow (M1 i c a) where + gtoRow (M1 a) = gtoRow a -instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) - => ToRow (a,b,c,d,e,f) where - toRow (a,b,c,d,e,f) = - [toField a, toField b, toField c, toField d, toField e, toField f] +-- | A collection type that can be turned into a list of 'SQLData' +-- elements. +-- +-- Since version 0.4.16.1 it is possible in some cases to derive a +-- generic implementation for 'ToRow'. Refer to the documentation for +-- 'Database.Sqlite.Simple.FromRow.FromRow' to see how this can be +-- done. +class ToRow a where + toRow :: a -> [SQLData] + -- ^ 'ToField' a collection of values. -instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, - ToField g) - => ToRow (a,b,c,d,e,f,g) where - toRow (a,b,c,d,e,f,g) = - [toField a, toField b, toField c, toField d, toField e, toField f, - toField g] + default toRow :: Generic a => GToRow (Rep a) => a -> [SQLData] + toRow a = gtoRow $ from a + +deriving instance ToRow () +deriving instance (ToField a) => ToRow (Only a) +deriving instance (ToField a, ToField b) => ToRow (a,b) +deriving instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) +deriving instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a,b,c,d,e) +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a,b,c,d,e,f) +deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a,b,c,d,e,f,g) instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) diff --git a/changelog b/changelog index 2a5a649..bbc3c9b 100644 --- a/changelog +++ b/changelog @@ -1,7 +1,13 @@ +0.4.16.2 + * Add instance for {From,To}Field for NominalDiffTime + +0.4.16.1 + * Add generic implementation of 'FromRow' and 'ToRow'. + 0.4.16.0 * Add FromField instance for SQLData (thanks @LindaOrtega, @Shimuuar) * Add QuasiQuoter sql (thanks @vrom911) - + 0.4.15.0 * Support GHC 8.4.1 (Add instance Semigroup Query) (thanks @gwils!) diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal index 9f2aa73..f87fa09 100644 --- a/sqlite-simple.cabal +++ b/sqlite-simple.cabal @@ -1,5 +1,5 @@ Name: sqlite-simple -Version: 0.4.16.0 +Version: 0.4.17.0 Synopsis: Mid-Level SQLite client library Description: Mid-level SQLite client library, based on postgresql-simple. diff --git a/stack.yaml b/stack.yaml index c332fca..3c8f1b1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -resolver: lts-11.9 +resolver: lts-12.0