mirror of
https://github.com/nikita-volkov/hasql.git
synced 2024-11-23 02:35:33 +03:00
Merge pull request #129 from k0001/fail-row
Add MonadFail instance for Row
This commit is contained in:
commit
be03e83b01
@ -113,7 +113,7 @@ x = (,,) '<$>' ('column' . 'nullable') 'int8' '<*>' ('column' . 'nonNullable') '
|
|||||||
@
|
@
|
||||||
-}
|
-}
|
||||||
newtype Row a = Row (Row.Row a)
|
newtype Row a = Row (Row.Row a)
|
||||||
deriving (Functor, Applicative, Monad)
|
deriving (Functor, Applicative, Monad, MonadFail)
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
Lift an individual non-nullable value decoder to a composable row decoder.
|
Lift an individual non-nullable value decoder to a composable row decoder.
|
||||||
@ -268,7 +268,7 @@ time = Value (Value.decoder (Prelude.bool A.time_float A.time_int))
|
|||||||
{-|
|
{-|
|
||||||
Decoder of the @TIMETZ@ values.
|
Decoder of the @TIMETZ@ values.
|
||||||
|
|
||||||
Unlike in case of @TIMESTAMPTZ@,
|
Unlike in case of @TIMESTAMPTZ@,
|
||||||
Postgres does store the timezone information for @TIMETZ@.
|
Postgres does store the timezone information for @TIMETZ@.
|
||||||
However the Haskell's \"time\" library does not contain any composite type,
|
However the Haskell's \"time\" library does not contain any composite type,
|
||||||
that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
|
that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone'
|
||||||
|
@ -3,14 +3,19 @@ module Hasql.Private.Decoders.Row where
|
|||||||
import Hasql.Private.Prelude hiding (error)
|
import Hasql.Private.Prelude hiding (error)
|
||||||
import Hasql.Private.Errors
|
import Hasql.Private.Errors
|
||||||
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
import qualified Database.PostgreSQL.LibPQ as LibPQ
|
||||||
|
import qualified Data.Text as T
|
||||||
import qualified PostgreSQL.Binary.Decoding as A
|
import qualified PostgreSQL.Binary.Decoding as A
|
||||||
import qualified Hasql.Private.Decoders.Value as Value
|
import qualified Hasql.Private.Decoders.Value as Value
|
||||||
|
import Control.Monad.Fail (MonadFail(..))
|
||||||
|
|
||||||
|
|
||||||
newtype Row a =
|
newtype Row a =
|
||||||
Row (ReaderT Env (ExceptT RowError IO) a)
|
Row (ReaderT Env (ExceptT RowError IO) a)
|
||||||
deriving (Functor, Applicative, Monad)
|
deriving (Functor, Applicative, Monad)
|
||||||
|
|
||||||
|
instance MonadFail Row where
|
||||||
|
fail = error . ValueError . T.pack
|
||||||
|
|
||||||
data Env =
|
data Env =
|
||||||
Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
|
Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column)
|
||||||
|
|
||||||
@ -35,14 +40,14 @@ error x =
|
|||||||
{-# INLINE value #-}
|
{-# INLINE value #-}
|
||||||
value :: Value.Value a -> Row (Maybe a)
|
value :: Value.Value a -> Row (Maybe a)
|
||||||
value valueDec =
|
value valueDec =
|
||||||
{-# SCC "value" #-}
|
{-# SCC "value" #-}
|
||||||
Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do
|
Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> ExceptT $ do
|
||||||
col <- readIORef columnRef
|
col <- readIORef columnRef
|
||||||
writeIORef columnRef (succ col)
|
writeIORef columnRef (succ col)
|
||||||
if col < columnsAmount
|
if col < columnsAmount
|
||||||
then do
|
then do
|
||||||
valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col
|
valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col
|
||||||
pure $
|
pure $
|
||||||
case valueMaybe of
|
case valueMaybe of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
Right Nothing
|
Right Nothing
|
||||||
@ -56,5 +61,5 @@ value valueDec =
|
|||||||
{-# INLINE nonNullValue #-}
|
{-# INLINE nonNullValue #-}
|
||||||
nonNullValue :: Value.Value a -> Row a
|
nonNullValue :: Value.Value a -> Row a
|
||||||
nonNullValue valueDec =
|
nonNullValue valueDec =
|
||||||
{-# SCC "nonNullValue" #-}
|
{-# SCC "nonNullValue" #-}
|
||||||
value valueDec >>= maybe (error UnexpectedNull) pure
|
value valueDec >>= maybe (error UnexpectedNull) pure
|
||||||
|
Loading…
Reference in New Issue
Block a user