diff --git a/lib/Database/PostgreSQL/Opium/FromRow.hs b/lib/Database/PostgreSQL/Opium/FromRow.hs index dc3c41b..91fd3ae 100644 --- a/lib/Database/PostgreSQL/Opium/FromRow.hs +++ b/lib/Database/PostgreSQL/Opium/FromRow.hs @@ -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