0636c4a · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

Move FromField and FromRow to new Conversion monad

commit0636c4aaaacca20fba1728315f2ab53031602a98 authorLeon P Smith <leon@melding-monads.com> dateSun 27 Jan 2013, 21:14 (14 years ago) parenteec01a8

4 files changed+47−43

compare with master

unifiedsplit

src/Database/PostgreSQL/Simple.hs+2−1 src/Database/PostgreSQL/Simple/FromField.hs+38−38 src/Database/PostgreSQL/Simple/FromRow.hs+1−3 src/Database/PostgreSQL/Simple/Internal.hs+6−1

src/Database/PostgreSQL/Simple.hs+2−1

@@ -557,7 +557,8 @@ finishQuery conn q result = do

557557 ncols <- PQ.nfields result

558558 forM' 0 (nrows-1) $ \row -> do

559559 let rw = Row row typeinfos result

560− case runStateT (runReaderT (unRP fromRow) rw) 0 of

560+ okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn

561+ case okvc of

561562 Ok (val,col) | col == ncols -> return val

562563 | otherwise -> do

563564 vals <- forM' 0 (ncols-1) $ \c -> do

src/Database/PostgreSQL/Simple/FromField.hs+38−38

@@ -47,7 +47,7 @@ module Database.PostgreSQL.Simple.FromField

4747

4848import Control.Applicative

4949 ( Applicative, (<|>), (<$>), pure )

50−import Control.Exception (SomeException(..), Exception)

50+import Control.Exception (Exception)

5151import Data.Attoparsec.Char8 hiding (Result)

5252import Data.Bits ((.&.), (.|.), shiftL)

5353import Data.ByteString (ByteString)

@@ -65,6 +65,7 @@ import Database.PostgreSQL.Simple.Internal

6565import Database.PostgreSQL.Simple.BuiltinTypes

6666import Database.PostgreSQL.Simple.Ok

6767import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))

68+import Database.PostgreSQL.Simple.TypeInfo

6869import Database.PostgreSQL.Simple.Time

6970import Database.PostgreSQL.Simple.Arrays

7071import qualified Database.PostgreSQL.LibPQ as PQ

@@ -104,10 +105,10 @@ data ResultError = Incompatible { errSQLType :: String

104105

105106instance Exception ResultError

106107

107−left :: Exception a => a -> Ok b

108−left = Errors . (:[]) . SomeException

108+left :: Exception a => a -> Conversion b

109+left = conversionError

109110

110−type FieldParser a = Field -> Maybe ByteString -> Ok a

111+type FieldParser a = Field -> Maybe ByteString -> Conversion a

111112

112113-- | A type that may be converted from a SQL type.

113114class FromField a where

@@ -137,8 +138,9 @@ class FromField a where

137138-- will check a per-connection cache, and then finally query the database's

138139-- meta-schema.

139140

140−typename :: Field -> ByteString

141−typename = typname . typ . typeinfo

141+typename :: Field -> Conversion ByteString

142+typename field = Conversion $ \conn -> do

143+ Ok . typname . typ <$> getTypeInfo conn (typeOid field)

142144

143145-- | Returns the name of the column. This is often determined by a table

144146-- definition, but it can be set using an @as@ clause.

@@ -238,7 +240,7 @@ instance FromField LB.ByteString where

238240 fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat

239241

240242unescapeBytea :: Field -> SB.ByteString

241− -> Ok (Binary SB.ByteString)

243+ -> Conversion (Binary SB.ByteString)

242244unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of

243245 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

244246 Just str -> pure (Binary str)

@@ -262,48 +264,43 @@ instance FromField [Char] where

262264 fromField f dat = ST.unpack <$> fromField f dat

263265

264266instance FromField UTCTime where

265− fromField = ff TimestampTZ "UTCTime" parseUTCTime

267+ fromField = ff TimestampTZ parseUTCTime

266268

267269instance FromField ZonedTime where

268− fromField = ff TimestampTZ "ZonedTime" parseZonedTime

270+ fromField = ff TimestampTZ parseZonedTime

269271

270272instance FromField LocalTime where

271− fromField = ff Timestamp "LocalTime" parseLocalTime

273+ fromField = ff Timestamp parseLocalTime

272274

273275instance FromField Day where

274− fromField = ff Date "Day" parseDay

276+ fromField = ff Date parseDay

275277

276278instance FromField TimeOfDay where

277− fromField = ff Time "TimeOfDay" parseTimeOfDay

279+ fromField = ff Time parseTimeOfDay

278280

279281instance FromField UTCTimestamp where

280− fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp

282+ fromField = ff TimestampTZ parseUTCTimestamp

281283

282284instance FromField ZonedTimestamp where

283− fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp

285+ fromField = ff TimestampTZ parseZonedTimestamp

284286

285287instance FromField LocalTimestamp where

286− fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp

288+ fromField = ff Timestamp parseLocalTimestamp

287289

288290instance FromField Date where

289− fromField = ff Date "Date" parseDate

291+ fromField = ff Date parseDate

290292

291−ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)

292− -> Field -> Maybe B8.ByteString -> Ok a

293−ff pgType hsType parse f mstr =

293+ff :: Typeable a

294+ => BuiltinType -> (B8.ByteString -> Either String a)

295+ -> Field -> Maybe B8.ByteString -> Conversion a

296+ff pgType parse f mstr =

294297 if typeOid f /= builtin2oid pgType

295− then err Incompatible ""

298+ then returnError Incompatible f ""

296299 else case mstr of

297− Nothing -> err UnexpectedNull ""

300+ Nothing -> returnError UnexpectedNull f ""

298301 Just str -> case parse str of

299− Left msg -> err ConversionFailed msg

302+ Left msg -> returnError ConversionFailed f msg

300303 Right val -> return val

301− where

302− err errC msg = left $ errC (B8.unpack (typename f))

303− (tableOid f)

304− (maybe "" B8.unpack (name f))

305− hsType

306− msg

307304{-# INLINE ff #-}

308305

309306instance (FromField a, FromField b) => FromField (Either a b) where

@@ -315,7 +312,7 @@ instance (FromField a, Typeable a) => FromField (Vector a) where

315312 (V.fromList <$>)

316313 (parseOnly (fromArray ',' f) (maybe "" id dat))

317314

318−fromArray :: (FromField a) => Char -> Field -> Parser (Ok [a])

315+fromArray :: (FromField a) => Char -> Field -> Parser (Conversion [a])

319316fromArray delim f = sequence . (parseIt <$>) <$> array delim

320317 where

321318 fElem = f{ typeinfo = TypeInfo tElem Nothing }

@@ -351,8 +348,8 @@ okInt = ok64

351348#endif

352349

353350doFromField :: forall a . (Typeable a)

354− => Field -> Compat -> (ByteString -> Ok a)

355− -> Maybe ByteString -> Ok a

351+ => Field -> Compat -> (ByteString -> Conversion a)

352+ -> Maybe ByteString -> Conversion a

356353doFromField f types cvt (Just bs)

357354 | Just typ <- oid2builtin (typoid $ typ $ typeinfo f)

358355 , mkCompat typ `compat` types = cvt bs

@@ -366,18 +363,21 @@ doFromField f _ _ _ = returnError UnexpectedNull f ""

366363-- constructor.

367364returnError :: forall a err . (Typeable a, Exception err)

368365 => (String -> Maybe PQ.Oid -> String -> String -> String -> err)

369− -> Field -> String -> Ok a

370−returnError mkErr f = left . mkErr (B.unpack (typename f))

371− (tableOid f)

372− (maybe "" B.unpack (name f))

373− (show (typeOf (undefined :: a)))

366+ -> Field -> String -> Conversion a

367+returnError mkErr f msg = do

368+ typnam <- typename f

369+ left $ mkErr (B.unpack typnam)

370+ (tableOid f)

371+ (maybe "" B.unpack (name f))

372+ (show (typeOf (undefined :: a)))

373+ msg

374374

375375atto :: forall a. (Typeable a)

376376 => Compat -> Parser a -> Field -> Maybe ByteString

377− -> Ok a

377+ -> Conversion a

378378atto types p0 f dat = doFromField f types (go p0) dat

379379 where

380− go :: Parser a -> ByteString -> Ok a

380+ go :: Parser a -> ByteString -> Conversion a

381381 go p s =

382382 case parseOnly p s of

383383 Left err -> returnError ConversionFailed f err

src/Database/PostgreSQL/Simple/FromRow.hs+1−3

@@ -25,12 +25,10 @@ module Database.PostgreSQL.Simple.FromRow

2525 ) where

2626

2727import Control.Applicative (Applicative(..), (<$>))

28−import Control.Exception (SomeException(..))

2928import Control.Monad (replicateM)

3029import Data.ByteString (ByteString)

3130import qualified Data.ByteString.Char8 as B

3231import Database.PostgreSQL.Simple.Types (Only(..))

33−import Database.PostgreSQL.Simple.Ok

3432import qualified Database.PostgreSQL.LibPQ as PQ

3533import Database.PostgreSQL.Simple.Internal

3634import Database.PostgreSQL.Simple.FromField

@@ -92,7 +90,7 @@ fieldWith fieldP = RP $ do

9290 ++ " slots in target type")

9391 "mismatch between number of columns to \

9492 \convert and number in target type"

95− lift (lift (Errors [SomeException convertError]))

93+ lift (lift (conversionError convertError))

9694 else do

9795 let typeinfo = typeinfos ! unCol column

9896 result = rowresult

src/Database/PostgreSQL/Simple/Internal.hs+6−1

@@ -24,6 +24,7 @@ import Prelude hiding (catch)

2424import Control.Applicative

2525import Control.Exception

2626import Control.Concurrent.MVar

27+import Control.Monad(MonadPlus(..))

2728import Data.ByteString(ByteString)

2829import qualified Data.ByteString.Char8 as B8

2930import Data.Char (ord)

@@ -291,7 +292,7 @@ data Row = Row {

291292 , rowresult :: !PQ.Result

292293 }

293294

294−newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }

295+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }

295296 deriving ( Functor, Applicative, Alternative, Monad )

296297

297298newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }

@@ -323,6 +324,10 @@ instance Monad Conversion where

323324 Ok a -> runConversion (f a) conn

324325 Errors err -> return (Errors err)

325326

327+instance MonadPlus Conversion where

328+ mzero = empty

329+ mplus = (<|>)

330+

326331conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b

327332conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn

328333