Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Move FromField and FromRow to new Conversion monad

  • Loading branch information...
commit 0636c4aaaacca20fba1728315f2ab53031602a98 1 parent eec01a8
@lpsmith authored
View
3  src/Database/PostgreSQL/Simple.hs
@@ -557,7 +557,8 @@ finishQuery conn q result = do
ncols <- PQ.nfields result
forM' 0 (nrows-1) $ \row -> do
let rw = Row row typeinfos result
- case runStateT (runReaderT (unRP fromRow) rw) 0 of
+ okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn
+ case okvc of
Ok (val,col) | col == ncols -> return val
| otherwise -> do
vals <- forM' 0 (ncols-1) $ \c -> do
View
76 src/Database/PostgreSQL/Simple/FromField.hs
@@ -47,7 +47,7 @@ module Database.PostgreSQL.Simple.FromField
import Control.Applicative
( Applicative, (<|>), (<$>), pure )
-import Control.Exception (SomeException(..), Exception)
+import Control.Exception (Exception)
import Data.Attoparsec.Char8 hiding (Result)
import Data.Bits ((.&.), (.|.), shiftL)
import Data.ByteString (ByteString)
@@ -65,6 +65,7 @@ import Database.PostgreSQL.Simple.Internal
import Database.PostgreSQL.Simple.BuiltinTypes
import Database.PostgreSQL.Simple.Ok
import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))
+import Database.PostgreSQL.Simple.TypeInfo
import Database.PostgreSQL.Simple.Time
import Database.PostgreSQL.Simple.Arrays
import qualified Database.PostgreSQL.LibPQ as PQ
@@ -104,10 +105,10 @@ data ResultError = Incompatible { errSQLType :: String
instance Exception ResultError
-left :: Exception a => a -> Ok b
-left = Errors . (:[]) . SomeException
+left :: Exception a => a -> Conversion b
+left = conversionError
-type FieldParser a = Field -> Maybe ByteString -> Ok a
+type FieldParser a = Field -> Maybe ByteString -> Conversion a
-- | A type that may be converted from a SQL type.
class FromField a where
@@ -137,8 +138,9 @@ class FromField a where
-- will check a per-connection cache, and then finally query the database's
-- meta-schema.
-typename :: Field -> ByteString
-typename = typname . typ . typeinfo
+typename :: Field -> Conversion ByteString
+typename field = Conversion $ \conn -> do
+ Ok . typname . typ <$> getTypeInfo conn (typeOid field)
-- | Returns the name of the column. This is often determined by a table
-- definition, but it can be set using an @as@ clause.
@@ -238,7 +240,7 @@ instance FromField LB.ByteString where
fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat
unescapeBytea :: Field -> SB.ByteString
- -> Ok (Binary SB.ByteString)
+ -> Conversion (Binary SB.ByteString)
unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of
Nothing -> returnError ConversionFailed f "unescapeBytea failed"
Just str -> pure (Binary str)
@@ -262,48 +264,43 @@ instance FromField [Char] where
fromField f dat = ST.unpack <$> fromField f dat
instance FromField UTCTime where
- fromField = ff TimestampTZ "UTCTime" parseUTCTime
+ fromField = ff TimestampTZ parseUTCTime
instance FromField ZonedTime where
- fromField = ff TimestampTZ "ZonedTime" parseZonedTime
+ fromField = ff TimestampTZ parseZonedTime
instance FromField LocalTime where
- fromField = ff Timestamp "LocalTime" parseLocalTime
+ fromField = ff Timestamp parseLocalTime
instance FromField Day where
- fromField = ff Date "Day" parseDay
+ fromField = ff Date parseDay
instance FromField TimeOfDay where
- fromField = ff Time "TimeOfDay" parseTimeOfDay
+ fromField = ff Time parseTimeOfDay
instance FromField UTCTimestamp where
- fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp
+ fromField = ff TimestampTZ parseUTCTimestamp
instance FromField ZonedTimestamp where
- fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp
+ fromField = ff TimestampTZ parseZonedTimestamp
instance FromField LocalTimestamp where
- fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp
+ fromField = ff Timestamp parseLocalTimestamp
instance FromField Date where
- fromField = ff Date "Date" parseDate
+ fromField = ff Date parseDate
-ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)
- -> Field -> Maybe B8.ByteString -> Ok a
-ff pgType hsType parse f mstr =
+ff :: Typeable a
+ => BuiltinType -> (B8.ByteString -> Either String a)
+ -> Field -> Maybe B8.ByteString -> Conversion a
+ff pgType parse f mstr =
if typeOid f /= builtin2oid pgType
- then err Incompatible ""
+ then returnError Incompatible f ""
else case mstr of
- Nothing -> err UnexpectedNull ""
+ Nothing -> returnError UnexpectedNull f ""
Just str -> case parse str of
- Left msg -> err ConversionFailed msg
+ Left msg -> returnError ConversionFailed f msg
Right val -> return val
- where
- err errC msg = left $ errC (B8.unpack (typename f))
- (tableOid f)
- (maybe "" B8.unpack (name f))
- hsType
- msg
{-# INLINE ff #-}
instance (FromField a, FromField b) => FromField (Either a b) where
@@ -315,7 +312,7 @@ instance (FromField a, Typeable a) => FromField (Vector a) where
(V.fromList <$>)
(parseOnly (fromArray ',' f) (maybe "" id dat))
-fromArray :: (FromField a) => Char -> Field -> Parser (Ok [a])
+fromArray :: (FromField a) => Char -> Field -> Parser (Conversion [a])
fromArray delim f = sequence . (parseIt <$>) <$> array delim
where
fElem = f{ typeinfo = TypeInfo tElem Nothing }
@@ -351,8 +348,8 @@ okInt = ok64
#endif
doFromField :: forall a . (Typeable a)
- => Field -> Compat -> (ByteString -> Ok a)
- -> Maybe ByteString -> Ok a
+ => Field -> Compat -> (ByteString -> Conversion a)
+ -> Maybe ByteString -> Conversion a
doFromField f types cvt (Just bs)
| Just typ <- oid2builtin (typoid $ typ $ typeinfo f)
, mkCompat typ `compat` types = cvt bs
@@ -366,18 +363,21 @@ doFromField f _ _ _ = returnError UnexpectedNull f ""
-- constructor.
returnError :: forall a err . (Typeable a, Exception err)
=> (String -> Maybe PQ.Oid -> String -> String -> String -> err)
- -> Field -> String -> Ok a
-returnError mkErr f = left . mkErr (B.unpack (typename f))
- (tableOid f)
- (maybe "" B.unpack (name f))
- (show (typeOf (undefined :: a)))
+ -> Field -> String -> Conversion a
+returnError mkErr f msg = do
+ typnam <- typename f
+ left $ mkErr (B.unpack typnam)
+ (tableOid f)
+ (maybe "" B.unpack (name f))
+ (show (typeOf (undefined :: a)))
+ msg
atto :: forall a. (Typeable a)
=> Compat -> Parser a -> Field -> Maybe ByteString
- -> Ok a
+ -> Conversion a
atto types p0 f dat = doFromField f types (go p0) dat
where
- go :: Parser a -> ByteString -> Ok a
+ go :: Parser a -> ByteString -> Conversion a
go p s =
case parseOnly p s of
Left err -> returnError ConversionFailed f err
View
4 src/Database/PostgreSQL/Simple/FromRow.hs
@@ -25,12 +25,10 @@ module Database.PostgreSQL.Simple.FromRow
) where
import Control.Applicative (Applicative(..), (<$>))
-import Control.Exception (SomeException(..))
import Control.Monad (replicateM)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Database.PostgreSQL.Simple.Types (Only(..))
-import Database.PostgreSQL.Simple.Ok
import qualified Database.PostgreSQL.LibPQ as PQ
import Database.PostgreSQL.Simple.Internal
import Database.PostgreSQL.Simple.FromField
@@ -92,7 +90,7 @@ fieldWith fieldP = RP $ do
++ " slots in target type")
"mismatch between number of columns to \
\convert and number in target type"
- lift (lift (Errors [SomeException convertError]))
+ lift (lift (conversionError convertError))
else do
let typeinfo = typeinfos ! unCol column
result = rowresult
View
7 src/Database/PostgreSQL/Simple/Internal.hs
@@ -24,6 +24,7 @@ import Prelude hiding (catch)
import Control.Applicative
import Control.Exception
import Control.Concurrent.MVar
+import Control.Monad(MonadPlus(..))
import Data.ByteString(ByteString)
import qualified Data.ByteString.Char8 as B8
import Data.Char (ord)
@@ -291,7 +292,7 @@ data Row = Row {
, rowresult :: !PQ.Result
}
-newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a }
+newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a }
deriving ( Functor, Applicative, Alternative, Monad )
newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) }
@@ -323,6 +324,10 @@ instance Monad Conversion where
Ok a -> runConversion (f a) conn
Errors err -> return (Errors err)
+instance MonadPlus Conversion where
+ mzero = empty
+ mplus = (<|>)
+
conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b
conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn
Please sign in to comment.
Something went wrong with that request. Please try again.