Clean up FromRow instances a little
This commit is contained in:
parent
7a14714cf6
commit
3ef1f5bbde
@ -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)
|
||||
|
||||
|
Loading…
x
Reference in New Issue
Block a user