0636c4a · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Move FromField and FromRow to new Conversion monad

0636c4aLeon P Smith14 years ago

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

compare with master

unifiedsplit

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

557 ncols <- PQ.nfields result

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

559 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

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

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

562 | otherwise -> do

563 | otherwise -> do

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

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

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

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

48import Control.Applicative

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

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

50+import Control.Exception (Exception)

51import Data.Attoparsec.Char8 hiding (Result)

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

53import Data.ByteString (ByteString)

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

65import Database.PostgreSQL.Simple.BuiltinTypes

66import Database.PostgreSQL.Simple.Ok

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

68+import Database.PostgreSQL.Simple.TypeInfo

68import Database.PostgreSQL.Simple.Time

69import Database.PostgreSQL.Simple.Time

69import Database.PostgreSQL.Simple.Arrays

70import Database.PostgreSQL.Simple.Arrays

70import qualified Database.PostgreSQL.LibPQ as PQ

71import qualified Database.PostgreSQL.LibPQ as PQ

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

104

105

105instance Exception ResultError

106instance Exception ResultError

106

107

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

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

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

109+left = conversionError

109

110

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

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

111

112

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

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

113class FromField a where

114class FromField a where

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

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

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

138-- meta-schema.

139-- meta-schema.

139

140

140−typename :: Field -> ByteString

141+typename :: Field -> Conversion ByteString

141−typename = typname . typ . typeinfo

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

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

142

144

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

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

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

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

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

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

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

239

241

240unescapeBytea :: Field -> SB.ByteString

242unescapeBytea :: Field -> SB.ByteString

241− -> Ok (Binary SB.ByteString)

243+ -> Conversion (Binary SB.ByteString)

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

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

243 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

245 Nothing -> returnError ConversionFailed f "unescapeBytea failed"

244 Just str -> pure (Binary str)

246 Just str -> pure (Binary str)

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

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

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

263

265

264instance FromField UTCTime where

266instance FromField UTCTime where

265− fromField = ff TimestampTZ "UTCTime" parseUTCTime

267+ fromField = ff TimestampTZ parseUTCTime

266

268

267instance FromField ZonedTime where

269instance FromField ZonedTime where

268− fromField = ff TimestampTZ "ZonedTime" parseZonedTime

270+ fromField = ff TimestampTZ parseZonedTime

269

271

270instance FromField LocalTime where

272instance FromField LocalTime where

271− fromField = ff Timestamp "LocalTime" parseLocalTime

273+ fromField = ff Timestamp parseLocalTime

272

274

273instance FromField Day where

275instance FromField Day where

274− fromField = ff Date "Day" parseDay

276+ fromField = ff Date parseDay

275

277

276instance FromField TimeOfDay where

278instance FromField TimeOfDay where

277− fromField = ff Time "TimeOfDay" parseTimeOfDay

279+ fromField = ff Time parseTimeOfDay

278

280

279instance FromField UTCTimestamp where

281instance FromField UTCTimestamp where

280− fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp

282+ fromField = ff TimestampTZ parseUTCTimestamp

281

283

282instance FromField ZonedTimestamp where

284instance FromField ZonedTimestamp where

283− fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp

285+ fromField = ff TimestampTZ parseZonedTimestamp

284

286

285instance FromField LocalTimestamp where

287instance FromField LocalTimestamp where

286− fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp

288+ fromField = ff Timestamp parseLocalTimestamp

287

289

288instance FromField Date where

290instance FromField Date where

289− fromField = ff Date "Date" parseDate

291+ fromField = ff Date parseDate

290

292

293+ff :: Typeable a

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

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

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

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

293−ff pgType hsType parse f mstr =

296+ff pgType parse f mstr =

294 if typeOid f /= builtin2oid pgType

297 if typeOid f /= builtin2oid pgType

295− then err Incompatible ""

298+ then returnError Incompatible f ""

296 else case mstr of

299 else case mstr of

297− Nothing -> err UnexpectedNull ""

300+ Nothing -> returnError UnexpectedNull f ""

298 Just str -> case parse str of

301 Just str -> case parse str of

299− Left msg -> err ConversionFailed msg

302+ Left msg -> returnError ConversionFailed f msg

300 Right val -> return val

303 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

307{-# INLINE ff #-}

304{-# INLINE ff #-}

308

305

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

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

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

315 (V.fromList <$>)

312 (V.fromList <$>)

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

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

317

314

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

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

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

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

320 where

317 where

321 fElem = f{ typeinfo = TypeInfo tElem Nothing }

318 fElem = f{ typeinfo = TypeInfo tElem Nothing }

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

351#endif

348#endif

352

349

353doFromField :: forall a . (Typeable a)

350doFromField :: forall a . (Typeable a)

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

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

355− -> Maybe ByteString -> Ok a

352+ -> Maybe ByteString -> Conversion a

356doFromField f types cvt (Just bs)

353doFromField f types cvt (Just bs)

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

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

358 , mkCompat typ `compat` types = cvt bs

355 , mkCompat typ `compat` types = cvt bs

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

366-- constructor.

363-- constructor.

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

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

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

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

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

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

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

367+returnError mkErr f msg = do

368+ typnam <- typename f

369+ left $ mkErr (B.unpack typnam)

371− (tableOid f)

370+ (tableOid f)

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

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

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

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

373+ msg

374

375atto :: forall a. (Typeable a)

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

377− -> Ok a

377+ -> Conversion a

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

379 where

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

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

381 go p s =

382 case parseOnly p s of

383 Left err -> returnError ConversionFailed f err

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

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

25 ) where

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

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

29import Control.Monad (replicateM)

28import Control.Monad (replicateM)

30import Data.ByteString (ByteString)

29import Data.ByteString (ByteString)

31import qualified Data.ByteString.Char8 as B

30import qualified Data.ByteString.Char8 as B

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

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

33−import Database.PostgreSQL.Simple.Ok

34import qualified Database.PostgreSQL.LibPQ as PQ

32import qualified Database.PostgreSQL.LibPQ as PQ

35import Database.PostgreSQL.Simple.Internal

33import Database.PostgreSQL.Simple.Internal

36import Database.PostgreSQL.Simple.FromField

34import Database.PostgreSQL.Simple.FromField

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

92 ++ " slots in target type")

90 ++ " slots in target type")

93 "mismatch between number of columns to \

91 "mismatch between number of columns to \

94 \convert and number in target type"

92 \convert and number in target type"

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

93+ lift (lift (conversionError convertError))

96 else do

94 else do

97 let typeinfo = typeinfos ! unCol column

95 let typeinfo = typeinfos ! unCol column

98 result = rowresult

96 result = rowresult

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

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

24import Control.Applicative

25import Control.Exception

26import Control.Concurrent.MVar

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

27import Data.ByteString(ByteString)

28import Data.ByteString(ByteString)

28import qualified Data.ByteString.Char8 as B8

29import qualified Data.ByteString.Char8 as B8

29import Data.Char (ord)

30import Data.Char (ord)

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

291 , rowresult :: !PQ.Result

292 , rowresult :: !PQ.Result

292 }

293 }

293

294

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 }

295 deriving ( Functor, Applicative, Alternative, Monad )

296 deriving ( Functor, Applicative, Alternative, Monad )

296

297

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

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

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

323 Ok a -> runConversion (f a) conn

324 Ok a -> runConversion (f a) conn

324 Errors err -> return (Errors err)

325 Errors err -> return (Errors err)

325

326

327+instance MonadPlus Conversion where

328+ mzero = empty

329+ mplus = (<|>)

330+

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

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

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

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

328

333