{-# LANGUAGE DataKinds, TypeOperators, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-}
{-# LANGUAGE TypeApplications, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Selda.FieldSelectors
(FieldType, HasField, IsLabel
) where
import Database.Selda.Generic (Relational)
import Database.Selda.Selectors as S ( Selector, unsafeSelector )
import Database.Selda.SqlType (SqlType)
import Data.Kind (Constraint)
import GHC.Generics
( Generic(Rep), K1, M1, type (:*:), S, Meta(MetaSel) )
import GHC.TypeLits
( Symbol, TypeError, ErrorMessage(Text, (:<>:), ShowType) )
import GHC.OverloadedLabels ( IsLabel(..) )
type family GetFieldType (f :: * -> *) :: * where
GetFieldType (M1 c i f) = GetFieldType f
GetFieldType (K1 i a) = a
type family GFieldType (a :: * -> *) (b :: *) (name :: Symbol) :: * where
GFieldType (M1 S ('MetaSel ('Just name) su ss ds) f) b name = GetFieldType f
GFieldType (M1 c i a) b name = GFieldType a b name
GFieldType (a :*: b) c name = GFieldType a (GFieldType b c name) name
GFieldType a b name = b
type FieldType name t = GFieldType (Rep t) (NoSuchSelector t name) name
type family NonError (t :: k) :: Constraint where
NonError (NoSuchSelector t s) = TypeError
( 'Text "Row type '" ':<>: 'ShowType t ':<>:
'Text "' has no selector " ':<>: 'ShowType s ':<>: 'Text "."
)
NonError t = ()
data NoSuchSelector (t :: *) (s :: Symbol)
class ( Relational t
, SqlType (FieldType name t)
, GRSel name (Rep t)
, NonError (FieldType name t)) =>
HasField (name :: Symbol) t
instance ( Relational t
, SqlType (FieldType name t)
, GRSel name (Rep t)
, NonError (FieldType name t)) =>
HasField (name :: Symbol) t
instance (Relational t, HasField name t, FieldType name t ~ a) =>
IsLabel name (S.Selector t a) where
fromLabel :: Selector t a
fromLabel = forall (name :: Symbol) t.
(Relational t, HasField name t) =>
Selector t (FieldType name t)
field @name @t
field :: forall name t.
(Relational t, HasField name t)
=> S.Selector t (FieldType name t)
field :: forall (name :: Symbol) t.
(Relational t, HasField name t) =>
Selector t (FieldType name t)
field =
case forall (s :: Symbol) (f :: * -> *).
GRSel s f =>
Int -> Either Int Int
gSel @name @(Rep t) Int
0 of
Left Int
n -> forall a b. (SqlRow a, SqlType b) => Int -> Selector a b
unsafeSelector Int
n
Either Int Int
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"unreachable"
class GRSel (s :: Symbol) (f :: * -> *) where
gSel :: Int -> Either Int Int
instance GRSel name (M1 S ('MetaSel ('Just name) su ss ds) f) where
gSel :: Int -> Either Int Int
gSel = forall a b. a -> Either a b
Left
instance {-# OVERLAPPABLE #-} GRSel name f => GRSel name (M1 i s f) where
gSel :: Int -> Either Int Int
gSel = forall (s :: Symbol) (f :: * -> *).
GRSel s f =>
Int -> Either Int Int
gSel @name @f
instance (GRSel name a, GRSel name b) => GRSel name (a :*: b) where
gSel :: Int -> Either Int Int
gSel Int
n = forall (s :: Symbol) (f :: * -> *).
GRSel s f =>
Int -> Either Int Int
gSel @name @a Int
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: Symbol) (f :: * -> *).
GRSel s f =>
Int -> Either Int Int
gSel @name @b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
succ
instance GRSel name (K1 i a) where
gSel :: Int -> Either Int Int
gSel = forall a b. b -> Either a b
Right