This commit is contained in:
Nikita Volkov 2015-11-20 07:59:49 +03:00
parent 4d9f3b90f5
commit 3dd489bc5f
4 changed files with 21 additions and 1 deletions

View File

@ -43,10 +43,12 @@ data Error =
UnexpectedAmountOfRows !Int UnexpectedAmountOfRows !Int
deriving (Show) deriving (Show)
{-# INLINE run #-}
run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a) run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a)
run (Result reader) env = run (Result reader) env =
runEitherT (runReaderT reader env) runEitherT (runReaderT reader env)
{-# INLINE unit #-}
unit :: Result () unit :: Result ()
unit = unit =
checkExecStatus $ \case checkExecStatus $ \case
@ -54,6 +56,7 @@ unit =
LibPQ.TuplesOk -> True LibPQ.TuplesOk -> True
_ -> False _ -> False
{-# INLINE rowsAffected #-}
rowsAffected :: Result Int64 rowsAffected :: Result Int64
rowsAffected = rowsAffected =
do do
@ -76,8 +79,10 @@ rowsAffected =
mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $ mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $
Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes
{-# INLINE checkExecStatus #-}
checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result ()
checkExecStatus predicate = checkExecStatus predicate =
{-# SCC "checkExecStatus" #-}
do do
status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result
unless (predicate status) $ do unless (predicate status) $ do
@ -87,6 +92,7 @@ checkExecStatus predicate =
LibPQ.FatalError -> serverError LibPQ.FatalError -> serverError
_ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status)
{-# INLINE serverError #-}
serverError :: Result () serverError :: Result ()
serverError = serverError =
Result $ ReaderT $ \(_, result) -> EitherT $ do Result $ ReaderT $ \(_, result) -> EitherT $ do
@ -102,6 +108,7 @@ serverError =
LibPQ.resultErrorField result LibPQ.DiagMessageHint LibPQ.resultErrorField result LibPQ.DiagMessageHint
pure $ Left $ ServerError code message detail hint pure $ Left $ ServerError code message detail hint
{-# INLINE maybe #-}
maybe :: Row.Row a -> Result (Maybe a) maybe :: Row.Row a -> Result (Maybe a)
maybe rowDes = maybe rowDes =
do do
@ -122,6 +129,7 @@ maybe rowDes =
intToRow = intToRow =
LibPQ.Row . fromIntegral LibPQ.Row . fromIntegral
{-# INLINE single #-}
single :: Row.Row a -> Result a single :: Row.Row a -> Result a
single rowDes = single rowDes =
do do
@ -141,8 +149,10 @@ single rowDes =
intToRow = intToRow =
LibPQ.Row . fromIntegral LibPQ.Row . fromIntegral
{-# INLINE generate #-}
generate :: (forall m. Monad m => Int -> (Int -> m a) -> m b) -> Row.Row a -> Result b generate :: (forall m. Monad m => Int -> (Int -> m a) -> m b) -> Row.Row a -> Result b
generate generateM rowDes = generate generateM rowDes =
{-# SCC "generate" #-}
do do
checkExecStatus $ \case checkExecStatus $ \case
LibPQ.TuplesOk -> True LibPQ.TuplesOk -> True
@ -159,8 +169,10 @@ generate generateM rowDes =
intToRow = intToRow =
LibPQ.Row . fromIntegral LibPQ.Row . fromIntegral
{-# INLINE foldl #-}
foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a
foldl step init rowDes = foldl step init rowDes =
{-# SCC "foldl" #-}
do do
checkExecStatus $ \case checkExecStatus $ \case
LibPQ.TuplesOk -> True LibPQ.TuplesOk -> True
@ -181,6 +193,7 @@ foldl step init rowDes =
intToRow = intToRow =
LibPQ.Row . fromIntegral LibPQ.Row . fromIntegral
{-# INLINE foldr #-}
foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a
foldr step init rowDes = foldr step init rowDes =
do do

View File

@ -42,7 +42,7 @@ clientError =
-- | -- |
-- Parse a single result. -- Parse a single result.
{-# INLINABLE single #-} {-# INLINE single #-}
single :: Result.Result a -> Results a single :: Result.Result a -> Results a
single resultDes = single resultDes =
Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do

View File

@ -22,19 +22,23 @@ data Error =
deriving (Show) deriving (Show)
{-# INLINE run #-}
run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a) run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a)
run (Row m) env = run (Row m) env =
flip evalStateT 0 (flip runReaderT env (runEitherT m)) flip evalStateT 0 (flip runReaderT env (runEitherT m))
{-# INLINE error #-}
error :: Error -> Row a error :: Error -> Row a
error x = error x =
Row (EitherT (return (Left x))) Row (EitherT (return (Left x)))
-- | -- |
-- Next value, decoded using the provided value deserializer. -- Next value, decoded using the provided value deserializer.
{-# INLINE value #-}
value :: Value.Value a -> Row (Maybe a) value :: Value.Value a -> Row (Maybe a)
value valueDes = value valueDes =
{-# SCC "value" #-}
Row $ EitherT $ ReaderT $ \(result, row, maxCol, integerDatetimes) -> StateT $ \col -> Row $ EitherT $ ReaderT $ \(result, row, maxCol, integerDatetimes) -> StateT $ \col ->
if col < maxCol if col < maxCol
then then
@ -45,6 +49,8 @@ value valueDes =
-- | -- |
-- Next value, decoded using the provided value deserializer. -- Next value, decoded using the provided value deserializer.
{-# INLINE nonNullValue #-}
nonNullValue :: Value.Value a -> Row a nonNullValue :: Value.Value a -> Row a
nonNullValue valueDes = nonNullValue valueDes =
{-# SCC "nonNullValue" #-}
value valueDes >>= maybe (error UnexpectedNull) pure value valueDes >>= maybe (error UnexpectedNull) pure

View File

@ -18,5 +18,6 @@ run (Value imp) integerDatetimes =
{-# INLINE decoder #-} {-# INLINE decoder #-}
decoder :: (Bool -> Decoder.Decoder a) -> Value a decoder :: (Bool -> Decoder.Decoder a) -> Value a
decoder = decoder =
{-# SCC "decoder" #-}
Value . ReaderT Value . ReaderT