git.iko.soy/typeable/postgresql-simple
on master help sign in
First Draft at a FromRow module
commit15ec0a6dde153f1507f1f4bd13d06a6257b7cfef authorLeon P Smith <leon@melding-monads.com> dateFri 2 Mar 2012, 16:04 (15 years ago) parent65f1de0
4 files changed+199−9
compare with master
unifiedsplit
postgresql-simple.cabal+4−1 src/Database/PostgreSQL/Simple/FromRow.hs+162 src/Database/PostgreSQL/Simple/Internal.hs+27−8 src/Database/PostgreSQL/Simple/Ok.hs+6
postgresql-simple.cabal+4−1
@@ -21,6 +21,7 @@ Library
2121 Database.PostgreSQL.Simple.BuiltinTypes
2222 Database.PostgreSQL.Simple.Field
2323 Database.PostgreSQL.Simple.FromField
24+ Database.PostgreSQL.Simple.FromRow
2425 Database.PostgreSQL.Simple.LargeObjects
2526 Database.PostgreSQL.Simple.Notification
2627 Database.PostgreSQL.Simple.Ok
@@ -46,7 +47,9 @@ Library
4647 old-locale,
4748 template-haskell,
4849 text >= 0.11.1,
49− time
50+ time,
51+ transformers,
52+ vector
5053
5154source-repository head
5255 type: git
src/Database/PostgreSQL/Simple/FromRow.hsnew file+162
@@ -0,0 +1,162 @@
1+{-# LANGUAGE RecordWildCards, BangPatterns #-}
2+
3+module Database.PostgreSQL.Simple.FromRow
4+ ( FromRow(..)
5+ , RowParser
6+ , field
7+ , numFieldsRemaining
8+ ) where
9+
10+import Control.Applicative (Applicative(..), (<$>))
11+import Control.Exception (SomeException(..), throw)
12+import Control.Monad (replicateM)
13+import Data.ByteString (ByteString)
14+import qualified Data.ByteString.Char8 as B
15+import Database.PostgreSQL.Simple.Internal
16+import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))
17+import Database.PostgreSQL.Simple.Types (Only(..))
18+import Database.PostgreSQL.Simple.Ok
19+import qualified Database.PostgreSQL.LibPQ as PQ
20+import Database.PostgreSQL.Simple.Internal
21+import Database.PostgreSQL.Simple.FromField
22+
23+import Control.Monad.Trans.State.Strict
24+import Control.Monad.Trans.Reader
25+import Control.Monad.Trans.Class
26+
27+import Data.Vector ((!))
28+
29+import System.IO.Unsafe ( unsafePerformIO )
30+
31+class FromRow a where
32+ fromRow :: RowParser a
33+
34+field :: FromField a => RowParser a
35+field = RP $ do
36+ Row{..} <- ask
37+ column <- lift get
38+ lift (put (column + 1))
39+ let typename = typenames ! (\(PQ.Col x) -> fromIntegral x) column
40+ result = rowresult
41+ field = Field{..}
42+ if (column > nfields rowresult) then lift (lift (Errors [])) else return ()
43+ lift (lift (fromField field (getvalue result row column)))
44+
45+numFieldsRemaining :: RowParser Int
46+numFieldsRemaining = RP $ do
47+ Row{..} <- ask
48+ column <- lift get
49+ return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)
50+
51+
52+instance (FromField a) => FromRow (Only a) where
53+ fromRow = do
54+ !a <- field
55+ return (Only a)
56+
57+instance (FromField a, FromField b) => FromRow (a,b) where
58+ fromRow = do
59+ !a <- field
60+ !b <- field
61+ return (a,b)
62+
63+instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where
64+ fromRow = do
65+ !a <- field
66+ !b <- field
67+ !c <- field
68+ return (a,b,c)
69+
70+instance (FromField a, FromField b, FromField c, FromField d) =>
71+ FromRow (a,b,c,d) where
72+ fromRow = do
73+ !a <- field
74+ !b <- field
75+ !c <- field
76+ !d <- field
77+ return (a,b,c,d)
78+
79+instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
80+ FromRow (a,b,c,d,e) where
81+ fromRow = do
82+ !a <- field
83+ !b <- field
84+ !c <- field
85+ !d <- field
86+ !e <- field
87+ return (a,b,c,d,e)
88+
89+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
90+ FromField f) =>
91+ FromRow (a,b,c,d,e,f) where
92+ fromRow = do
93+ !a <- field
94+ !b <- field
95+ !c <- field
96+ !d <- field
97+ !e <- field
98+ !f <- field
99+ return (a,b,c,d,e,f)
100+
101+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
102+ FromField f, FromField g) =>
103+ FromRow (a,b,c,d,e,f,g) where
104+ fromRow = do
105+ !a <- field
106+ !b <- field
107+ !c <- field
108+ !d <- field
109+ !e <- field
110+ !f <- field
111+ !g <- field
112+ return (a,b,c,d,e,f,g)
113+
114+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
115+ FromField f, FromField g, FromField h) =>
116+ FromRow (a,b,c,d,e,f,g,h) where
117+ fromRow = do
118+ !a <- field
119+ !b <- field
120+ !c <- field
121+ !d <- field
122+ !e <- field
123+ !f <- field
124+ !g <- field
125+ !h <- field
126+ return (a,b,c,d,e,f,g,h)
127+
128+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
129+ FromField f, FromField g, FromField h, FromField i) =>
130+ FromRow (a,b,c,d,e,f,g,h,i) where
131+ fromRow = do
132+ !a <- field
133+ !b <- field
134+ !c <- field
135+ !d <- field
136+ !e <- field
137+ !f <- field
138+ !g <- field
139+ !h <- field
140+ !i <- field
141+ return (a,b,c,d,e,f,g,h,i)
142+
143+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
144+ FromField f, FromField g, FromField h, FromField i, FromField j) =>
145+ FromRow (a,b,c,d,e,f,g,h,i,j) where
146+ fromRow = do
147+ !a <- field
148+ !b <- field
149+ !c <- field
150+ !d <- field
151+ !e <- field
152+ !f <- field
153+ !g <- field
154+ !h <- field
155+ !i <- field
156+ !j <- field
157+ return (a,b,c,d,e,f,g,h,i,j)
158+
159+instance FromField a => FromRow [a] where
160+ fromRow = do
161+ n <- numFieldsRemaining
162+ replicateM n field
src/Database/PostgreSQL/Simple/Internal.hs+27−8
@@ -1,5 +1,5 @@
11{-# LANGUAGE OverloadedStrings, NamedFieldPuns, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
33------------------------------------------------------------------------------
44-- |
55-- Module: Database.PostgreSQL.Simple.Internal
@@ -10,10 +10,10 @@
1010-- Portability: portable
1111--
1212-- Internal bits. This interface is less stable and can change at any time.
13−-- In particular this means that while the rest of the postgresql-simple
14−-- package endeavors to follow the package versioning policy, this module
15−-- does not. Also, at the moment there are things in here that aren't
16−-- particularly internal and are exported elsewhere; these will eventually
13+-- In particular this means that while the rest of the postgresql-simple
14+-- package endeavors to follow the package versioning policy, this module
15+-- does not. Also, at the moment there are things in here that aren't
16+-- particularly internal and are exported elsewhere; these will eventually
1717-- disappear from this module.
1818--
1919------------------------------------------------------------------------------
@@ -33,6 +33,10 @@ import Data.Word
3333import Database.PostgreSQL.LibPQ(Oid(..))
3434import qualified Database.PostgreSQL.LibPQ as PQ
3535import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)
36+import Database.PostgreSQL.Simple.Ok
37+import Control.Monad.Trans.State.Strict
38+import Control.Monad.Trans.Reader
39+import qualified Data.Vector as V
3640import System.IO.Unsafe (unsafePerformIO)
3741
3842-- | A Field represents metadata about a particular field
@@ -42,9 +46,9 @@ import System.IO.Unsafe (unsafePerformIO)
4246-- just the field metadata
4347
4448data Field = Field {
45− result :: PQ.Result
46− , column :: PQ.Column
47− , typename :: ByteString
49+ result :: !PQ.Result
50+ , column :: {-# UNPACK #-} !PQ.Column
51+ , typename :: !ByteString
4852 }
4953
5054name :: Field -> Maybe ByteString
@@ -225,3 +229,18 @@ newNullConnection = do
225229 return Connection{..}
226230
227231data RawResult = RawResult { rawField :: Field, rawData :: Maybe ByteString }
232+
233+data Row = Row {
234+ row :: {-# UNPACK #-} !PQ.Row
235+ , typenames :: !(V.Vector ByteString)
236+ , rowresult :: !PQ.Result
237+ }
238+
239+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }
240+ deriving ( Functor, Applicative, Alternative, Monad )
241+
242+getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString
243+getvalue result row col = unsafePerformIO (PQ.getvalue result row col)
244+
245+nfields :: PQ.Result -> PQ.Column
246+nfields result = unsafePerformIO (PQ.nfields result)
src/Database/PostgreSQL/Simple/Ok.hs+6
@@ -5,6 +5,7 @@ module Database.PostgreSQL.Simple.Ok where
55
66import Control.Applicative
77import Control.Exception
8+import Control.Monad(MonadPlus(..))
89import Data.Typeable
910
1011-- FIXME: [SomeException] should probably be a difference list
@@ -31,6 +32,11 @@ instance Alternative Ok where
3132 Errors _ <|> b@(Ok _) = b
3233 Errors as <|> Errors bs = Errors (as ++ bs)
3334
35+
36+instance MonadPlus Ok where
37+ mzero = empty
38+ mplus = (<|>)
39+
3440instance Monad Ok where
3541 return = Ok
3642