Move record member counting out of FromRow' into its own type family
This commit is contained in:
parent
e8ccecc8c7
commit
2caa00c06a
@ -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
|
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
|
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'.
|
-- | State kept for a call to 'fromRow'.
|
||||||
data FromRowCtx = FromRowCtx
|
data FromRowCtx = FromRowCtx
|
||||||
Result -- ^ Obtained from 'LibPQ.execParams'.
|
Result -- ^ Obtained from 'LibPQ.execParams'.
|
||||||
@ -91,28 +102,18 @@ data FromRowCtx = FromRowCtx
|
|||||||
data FRProxy (n :: Nat) (f :: Type -> Type) = FRProxy
|
data FRProxy (n :: Nat) (f :: Type -> Type) = FRProxy
|
||||||
|
|
||||||
class FromRow' (n :: Nat) (f :: Type -> Type) where
|
class FromRow' (n :: Nat) (f :: Type -> Type) where
|
||||||
type Members f :: Nat
|
|
||||||
|
|
||||||
fromRow' :: FRProxy n f -> FromRowCtx -> Row -> ExceptT Error IO (f p)
|
fromRow' :: FRProxy n f -> FromRowCtx -> Row -> ExceptT Error IO (f p)
|
||||||
|
|
||||||
instance FromRow' n f => FromRow' n (M1 D c f) where
|
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
|
fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
|
||||||
|
|
||||||
instance FromRow' n f => FromRow' n (M1 C c f) where
|
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
|
fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
|
||||||
|
|
||||||
instance (FromRow' n f, FromRow' (n + Members f) g) => FromRow' n (f :*: g) where
|
instance (FromRow' n f, FromRow' (n + NumberOfMembers 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 + NumberOfMembers f) FRProxy ctx row
|
||||||
|
|
||||||
fromRow' FRProxy ctx row = (:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + Members 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
|
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 ->
|
fromRow' FRProxy = decodeField memberIndex nameText $ \row ->
|
||||||
maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
|
maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
|
||||||
where
|
where
|
||||||
@ -120,8 +121,6 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) =>
|
|||||||
nameText = Text.pack $ symbolVal @nameSym Proxy
|
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
|
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
|
fromRow' FRProxy = decodeField memberIndex nameText $ const pure
|
||||||
where
|
where
|
||||||
memberIndex = fromIntegral $ natVal @n Proxy
|
memberIndex = fromIntegral $ natVal @n Proxy
|
||||||
|
Loading…
x
Reference in New Issue
Block a user