c901960 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Merge pull request #149 from Shimuuar/generic

Implement default instances for {To,From}Row using Generic

commitc901960d26a1b7dd5a2cf058489bf68a7c4ffa00 authorLeon P Smith <leon.p.smith+github@gmail.com> dateSun 18 Oct 2015, 12:54 (11 years ago) parentd90815d f9906e8

5 files changed+97−4

compare with master

unifiedsplit

postgresql-simple.cabal+1−1 src/Database/PostgreSQL/Simple/FromRow.hs+27−2 src/Database/PostgreSQL/Simple/ToRow.hs+21 src/Database/PostgreSQL/Simple/ToRow.hs-boot+10−1 test/Main.hs+38

postgresql-simple.cabal+1−1

@@ -56,7 +56,7 @@ Library

5656 Build-depends:

5757 aeson >= 0.6,

5858 attoparsec >= 0.10.3,

59− base < 5,

59+ base >= 4.4 && < 5,

6060 bytestring >= 0.9,

6161 bytestring-builder,

6262 case-insensitive,

src/Database/PostgreSQL/Simple/FromRow.hs+27−2

@@ -1,4 +1,6 @@

1−{-# LANGUAGE RecordWildCards, FlexibleInstances #-}

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}

35------------------------------------------------------------------------------

46-- |

@@ -27,7 +29,7 @@ module Database.PostgreSQL.Simple.FromRow

2729 ) where

2830

2931import Prelude hiding (null)

30−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))

32+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)

3133import Control.Monad (replicateM, replicateM_)

3234import Control.Monad.Trans.State.Strict

3335import Control.Monad.Trans.Reader

@@ -45,6 +47,9 @@ import Database.PostgreSQL.Simple.Ok

4547import Database.PostgreSQL.Simple.Types ((:.)(..), Null)

4648import Database.PostgreSQL.Simple.TypeInfo

4749

50+import GHC.Generics

51+

52+

4853-- | A collection type that can be converted from a sequence of fields.

4954-- Instances are provided for tuples up to 10 elements and lists of any length.

5055--

@@ -68,6 +73,8 @@ import Database.PostgreSQL.Simple.TypeInfo

6873

6974class FromRow a where

7075 fromRow :: RowParser a

76+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a

77+ fromRow = to <$> gfromRow

7178

7279getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString

7380getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)

@@ -252,3 +259,21 @@ instance FromField a => FromRow (Maybe (Vector a)) where

252259

253260instance (FromRow a, FromRow b) => FromRow (a :. b) where

254261 fromRow = (:.) <$> fromRow <*> fromRow

262+

263+

264+

265+-- Type class for default implementation of FromRow using generics

266+class GFromRow f where

267+ gfromRow :: RowParser (f p)

268+

269+instance GFromRow f => GFromRow (M1 c i f) where

270+ gfromRow = M1 <$> gfromRow

271+

272+instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where

273+ gfromRow = liftA2 (:*:) gfromRow gfromRow

274+

275+instance (FromField a) => GFromRow (K1 R a) where

276+ gfromRow = K1 <$> field

277+

278+instance GFromRow U1 where

279+ gfromRow = pure U1

src/Database/PostgreSQL/Simple/ToRow.hs+21

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

12------------------------------------------------------------------------------

23-- |

34-- Module: Database.PostgreSQL.Simple.ToRow

@@ -22,6 +23,7 @@ module Database.PostgreSQL.Simple.ToRow

2223

2324import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))

2425import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))

26+import GHC.Generics

2527

2628-- | A collection type that can be turned into a list of rendering

2729-- 'Action's.

@@ -30,6 +32,8 @@ import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))

3032-- to perform conversion of each element of the collection.

3133class ToRow a where

3234 toRow :: a -> [Action]

35+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

36+ toRow = gtoRow . from

3337 -- ^ ToField a collection of values.

3438

3539instance ToRow () where

@@ -90,3 +94,20 @@ instance (ToField a) => ToRow [a] where

9094

9195instance (ToRow a, ToRow b) => ToRow (a :. b) where

9296 toRow (a :. b) = toRow a ++ toRow b

97+

98+

99+-- Type class for default implementation of ToRow using generics

100+class GToRow f where

101+ gtoRow :: f p -> [Action]

102+

103+instance GToRow f => GToRow (M1 c i f) where

104+ gtoRow (M1 x) = gtoRow x

105+

106+instance (GToRow f, GToRow g) => GToRow (f :*: g) where

107+ gtoRow (f :*: g) = gtoRow f ++ gtoRow g

108+

109+instance (ToField a) => GToRow (K1 R a) where

110+ gtoRow (K1 a) = [toField a]

111+

112+instance GToRow U1 where

113+ gtoRow _ = []

src/Database/PostgreSQL/Simple/ToRow.hs-boot+10−1

@@ -1,9 +1,18 @@

1−module Database.PostgreSQL.Simple.ToRow where

1+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}

2+module Database.PostgreSQL.Simple.ToRow (

3+ ToRow(..)

4+ ) where

36import Database.PostgreSQL.Simple.Types

47import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField

8+import GHC.Generics

610class ToRow a where

711 toRow :: a -> [Action]

12+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]

13+ toRow = gtoRow . from

14+

15+class GToRow f where

16+ gtoRow :: f p -> [Action]

817

918instance ToField a => ToRow (Only a)

test/Main.hs+38

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DeriveGeneric #-}

12{-# LANGUAGE DeriveDataTypeable #-}

23{-# LANGUAGE DoAndIfThenElse #-}

34{-# LANGUAGE ScopedTypeVariables #-}

@@ -23,6 +24,7 @@ import System.Exit (exitFailure)

2324import System.IO

2425import qualified Data.Vector as V

2526import Data.Aeson

27+import GHC.Generics (Generic)

2628

2729import Notify

2830import Serializable

@@ -44,6 +46,9 @@ tests =

4446 , TestLabel "Values" . testValues

4547 , TestLabel "Copy" . testCopy

4648 , TestLabel "Double" . testDouble

49+ , TestLabel "1-ary generic" . testGeneric1

50+ , TestLabel "2-ary generic" . testGeneric2

51+ , TestLabel "3-ary generic" . testGeneric3

4752 ]

4853

4954testBytea :: TestEnv -> Test

@@ -320,6 +325,39 @@ testDouble TestEnv{..} = TestCase $ do

320325 x @?= (-1 / 0)

321326

322327

328+testGeneric1 :: TestEnv -> Test

329+testGeneric1 TestEnv{..} = TestCase $ do

330+ let x0 = Gen1 123

331+ r <- query conn "SELECT ?::int" x0

332+ r @?= [x0]

333+

334+testGeneric2 :: TestEnv -> Test

335+testGeneric2 TestEnv{..} = TestCase $ do

336+ let x0 = Gen2 123 "asdf"

337+ r <- query conn "SELECT ?::int, ?::text" x0

338+ r @?= [x0]

339+

340+testGeneric3 :: TestEnv -> Test

341+testGeneric3 TestEnv{..} = TestCase $ do

342+ let x0 = Gen3 123 "asdf" True

343+ r <- query conn "SELECT ?::int, ?::text, ?::bool" x0

344+ r @?= [x0]

345+

346+data Gen1 = Gen1 Int

347+ deriving (Show,Eq,Generic)

348+instance FromRow Gen1

349+instance ToRow Gen1

350+

351+data Gen2 = Gen2 Int Text

352+ deriving (Show,Eq,Generic)

353+instance FromRow Gen2

354+instance ToRow Gen2

355+

356+data Gen3 = Gen3 Int Text Bool

357+ deriving (Show,Eq,Generic)

358+instance FromRow Gen3

359+instance ToRow Gen3

360+

323361data TestException

324362 = TestException

325363 deriving (Eq, Show, Typeable)