Clean up FromRow instances a little

This commit is contained in:
Paul Brinkmeier 2023-09-05 16:23:29 +02:00
parent 7a14714cf6
commit 3ef1f5bbde

View File

@ -28,7 +28,7 @@ import Database.PostgreSQL.LibPQ
, Row
)
import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
@ -80,25 +80,19 @@ instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where
z <- fromRow' row result
pure $ (:*:) <$> y <*> z
-- TODO: Can we clean this up?
decodeField
:: FromField t
=> Text
-> (Row -> Maybe t -> Either Error t')
-> Row
-> Result
-> IO (Either Error (M1 S ('MetaSel ('Just (nameSym :: Symbol)) nu ns dl) (Rec0 t') p))
-> IO (Either Error (M1 S m (Rec0 t') p))
decodeField nameText g row result = runExceptT $ do
column <- getColumn
oid <- ExceptT $ Right <$> LibPQ.ftype result column
mbField <- getValue column
value <- case mbField of
Nothing ->
except $ g row Nothing
Just field -> do
value <- except $ mapLeft (ErrorDecode row nameText) $ fromField oid $ Encoding.decodeUtf8 field
except $ g row $ Just value
oid <- ExceptT $ pure <$> LibPQ.ftype result column
mbField <- getFieldText column
mbValue <- getValue oid mbField
value <- except $ g row mbValue
pure $ M1 $ K1 value
where
name = Encoding.encodeUtf8 nameText
@ -107,13 +101,19 @@ decodeField nameText g row result = runExceptT $ do
getColumn = ExceptT $
maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name
getValue :: Column -> ExceptT Error IO (Maybe ByteString)
getValue column = ExceptT $ Right <$> LibPQ.getvalue result row column
getFieldText :: Column -> ExceptT Error IO (Maybe Text)
getFieldText column =
ExceptT $ Right . fmap Encoding.decodeUtf8 <$> LibPQ.getvalue result row column
getValue :: FromField u => LibPQ.Oid -> Maybe Text -> ExceptT Error IO (Maybe u)
getValue oid = except . maybe
(Right Nothing)
(fmap Just . mapLeft (ErrorDecode row nameText) . fromField oid)
instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
fromRow' = decodeField nameText $ \row -> \case
Nothing -> Left $ ErrorUnexpectedNull row nameText
Just value -> Right value
fromRow' = decodeField nameText $ \row -> maybe
(Left $ ErrorUnexpectedNull row nameText)
Right
where
nameText = Text.pack $ symbolVal (Proxy :: Proxy nameSym)