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

Move record member counting out of FromRow' into its own type family

Browse Source
This commit is contained in:
Paul Brinkmeier 2024-06-20 20:07:37 +02:00
parent e8ccecc8c7
commit 2caa00c06a
1 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
lib/Database/PostgreSQL/Opium/FromRow.hs
View File

@ -83,6 +83,17 @@ instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTab
instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
-- | Number of members in the generic representation of a record type (doesn't support sum types).
type family NumberOfMembers f where
-- The data type itself has as many members as the type that it defines.
NumberOfMembers (M1 D _ f) = NumberOfMembers f
-- The constructor has as many members as the type that it contains.
NumberOfMembers (M1 C _ f) = NumberOfMembers f
-- A product type has as many types as its subtypes have together.
NumberOfMembers (f :*: g) = NumberOfMembers f + NumberOfMembers g
-- A selector has/is exactly one member.
NumberOfMembers (M1 S _ f) = 1
-- | State kept for a call to 'fromRow'.
data FromRowCtx = FromRowCtx
Result -- ^ Obtained from 'LibPQ.execParams'.
@ -91,28 +102,18 @@ data FromRowCtx = FromRowCtx
data FRProxy (n :: Nat) (f :: Type -> Type) = FRProxy
class FromRow' (n :: Nat) (f :: Type -> Type) where
type Members f :: Nat
fromRow' :: FRProxy n f -> FromRowCtx -> Row -> ExceptT Error IO (f p)
instance FromRow' n f => FromRow' n (M1 D c f) where
type Members (M1 D c f) = Members f
fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
instance FromRow' n f => FromRow' n (M1 C c f) where
type Members (M1 C c f) = Members f
fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
instance (FromRow' n f, FromRow' (n + Members f) g) => FromRow' n (f :*: g) where
type Members (f :*: g) = Members f + Members g
fromRow' FRProxy ctx row = (:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + Members f) FRProxy ctx row
instance (FromRow' n f, FromRow' (n + NumberOfMembers f) g) => FromRow' n (f :*: g) where
fromRow' FRProxy ctx row = (:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + NumberOfMembers f) FRProxy ctx row
instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
type Members (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) = 1
fromRow' FRProxy = decodeField memberIndex nameText $ \row ->
maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
where
@ -120,8 +121,6 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) =>
nameText = Text.pack $ symbolVal @nameSym Proxy
instance {-# OVERLAPPING #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
type Members (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) = 1
fromRow' FRProxy = decodeField memberIndex nameText $ const pure
where
memberIndex = fromIntegral $ natVal @n Proxy