paul/opium
1
0
Fork 0
Code Issues 1 Pull Requests Packages Projects Releases Wiki Activity

Clean up FromRow instances a little

Browse Source
This commit is contained in:
Paul Brinkmeier 2023-09-05 16:23:29 +02:00
parent 7a14714cf6
commit 3ef1f5bbde
1 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
lib/Database/PostgreSQL/Opium.hs
View File

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