git.iko.soy/typeable/postgresql-simple
on master help sign in
Merge pull request #149 from Shimuuar/generic
c901960Leon P Smith
postgresql-simple.cabal+1−1
compare with master
unifiedsplit
@@ -56,7 +56,7 @@ Library
56 Build-depends:
56 Build-depends:
57 aeson >= 0.6,
57 aeson >= 0.6,
58 attoparsec >= 0.10.3,
58 attoparsec >= 0.10.3,
59− base < 5,
59+ base >= 4.4 && < 5,
60 bytestring >= 0.9,
60 bytestring >= 0.9,
61 bytestring-builder,
61 bytestring-builder,
62 case-insensitive,
62 case-insensitive,
src/Database/PostgreSQL/Simple/FromRow.hs+27−2
@@ -1,4 +1,6 @@
1+{-# LANGUAGE FlexibleContexts #-}
1−{-# LANGUAGE RecordWildCards, FlexibleInstances #-}
2+{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-}
3+
2
4
3------------------------------------------------------------------------------
5------------------------------------------------------------------------------
4-- |
6-- |
@@ -27,7 +29,7 @@ module Database.PostgreSQL.Simple.FromRow
27 ) where
29 ) where
28
30
29import Prelude hiding (null)
31import Prelude hiding (null)
30−import Control.Applicative (Applicative(..), (<$>), (<|>), (*>))
32+import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2)
31import Control.Monad (replicateM, replicateM_)
33import Control.Monad (replicateM, replicateM_)
32import Control.Monad.Trans.State.Strict
34import Control.Monad.Trans.State.Strict
33import Control.Monad.Trans.Reader
35import Control.Monad.Trans.Reader
@@ -45,6 +47,9 @@ import Database.PostgreSQL.Simple.Ok
45import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
47import Database.PostgreSQL.Simple.Types ((:.)(..), Null)
46import Database.PostgreSQL.Simple.TypeInfo
48import Database.PostgreSQL.Simple.TypeInfo
47
49
50+import GHC.Generics
51+
52+
48-- | A collection type that can be converted from a sequence of fields.
53-- | A collection type that can be converted from a sequence of fields.
49-- Instances are provided for tuples up to 10 elements and lists of any length.
54-- Instances are provided for tuples up to 10 elements and lists of any length.
50--
55--
@@ -68,6 +73,8 @@ import Database.PostgreSQL.Simple.TypeInfo
68
73
69class FromRow a where
74class FromRow a where
70 fromRow :: RowParser a
75 fromRow :: RowParser a
76+ default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a
77+ fromRow = to <$> gfromRow
71
78
72getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
79getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
73getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
80getvalue result row col = unsafeDupablePerformIO (PQ.getvalue' result row col)
@@ -252,3 +259,21 @@ instance FromField a => FromRow (Maybe (Vector a)) where
252
259
253instance (FromRow a, FromRow b) => FromRow (a :. b) where
260instance (FromRow a, FromRow b) => FromRow (a :. b) where
254 fromRow = (:.) <$> fromRow <*> fromRow
261 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 #-}
1------------------------------------------------------------------------------
2------------------------------------------------------------------------------
2-- |
3-- |
3-- Module: Database.PostgreSQL.Simple.ToRow
4-- Module: Database.PostgreSQL.Simple.ToRow
@@ -22,6 +23,7 @@ module Database.PostgreSQL.Simple.ToRow
22
23
23import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
24import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))
24import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
25import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
26+import GHC.Generics
25
27
26-- | A collection type that can be turned into a list of rendering
28-- | A collection type that can be turned into a list of rendering
27-- 'Action's.
29-- 'Action's.
@@ -30,6 +32,8 @@ import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..))
30-- to perform conversion of each element of the collection.
32-- to perform conversion of each element of the collection.
31class ToRow a where
33class ToRow a where
32 toRow :: a -> [Action]
34 toRow :: a -> [Action]
35+ default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
36+ toRow = gtoRow . from
33 -- ^ ToField a collection of values.
37 -- ^ ToField a collection of values.
34
38
35instance ToRow () where
39instance ToRow () where
@@ -90,3 +94,20 @@ instance (ToField a) => ToRow [a] where
90
94
91instance (ToRow a, ToRow b) => ToRow (a :. b) where
95instance (ToRow a, ToRow b) => ToRow (a :. b) where
92 toRow (a :. b) = toRow a ++ toRow b
96 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+{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-}
1−module Database.PostgreSQL.Simple.ToRow where
2+module Database.PostgreSQL.Simple.ToRow (
3+ ToRow(..)
4+ ) where
2
5
3import Database.PostgreSQL.Simple.Types
6import Database.PostgreSQL.Simple.Types
4import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
7import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField
8+import GHC.Generics
5
9
6class ToRow a where
10class ToRow a where
7 toRow :: a -> [Action]
11 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]
8
17
9instance ToField a => ToRow (Only a)
18instance ToField a => ToRow (Only a)
test/Main.hs+38
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
@@ -23,6 +24,7 @@ import System.Exit (exitFailure)
23import System.IO
24import System.IO
24import qualified Data.Vector as V
25import qualified Data.Vector as V
25import Data.Aeson
26import Data.Aeson
27+import GHC.Generics (Generic)
26
28
27import Notify
29import Notify
28import Serializable
30import Serializable
@@ -44,6 +46,9 @@ tests =
44 , TestLabel "Values" . testValues
46 , TestLabel "Values" . testValues
45 , TestLabel "Copy" . testCopy
47 , TestLabel "Copy" . testCopy
46 , TestLabel "Double" . testDouble
48 , TestLabel "Double" . testDouble
49+ , TestLabel "1-ary generic" . testGeneric1
50+ , TestLabel "2-ary generic" . testGeneric2
51+ , TestLabel "3-ary generic" . testGeneric3
47 ]
52 ]
48
53
49testBytea :: TestEnv -> Test
54testBytea :: TestEnv -> Test
@@ -320,6 +325,39 @@ testDouble TestEnv{..} = TestCase $ do
320 x @?= (-1 / 0)
325 x @?= (-1 / 0)
321
326
322
327
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+
323data TestException
361data TestException
324 = TestException
362 = TestException
325 deriving (Eq, Show, Typeable)
363 deriving (Eq, Show, Typeable)