{-# LANGUAGE DataKinds, TypeOperators, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes, TypeFamilies #-}
{-# LANGUAGE UndecidableInstances, ConstraintKinds, UndecidableSuperClasses #-}
{-# LANGUAGE TypeApplications, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Create Selda selectors from plain record field selectors.
--   Requires the @OverloadedLabels@ language extension.
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(..) )

-- | Get the next nested type.
type family GetFieldType (f :: * -> *) :: * where
  GetFieldType (M1 c i f) = GetFieldType f
  GetFieldType (K1 i a)   = a

-- | Get the type of the field @name@ from the generic representation @a@,
--   returning the default value @b@ if the field does not exist.
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

-- | The type of the @name@ field, in the record type @t@.
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 = ()

-- | Internal representation of the "no such selector" error message.
data NoSuchSelector (t :: *) (s :: Symbol)

-- | Any table type @t@, which has a field named @name@.
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




-- | Create a selector from a record selector and a type application.
--
--   For example:
-- > data Foo = Foo
-- >   { foo :: Int
-- >   , bar :: Text
-- >   } deriving Generic
-- > instance SqlRow Foo
-- >
-- > fooTable :: Table Foo
-- > fooTable = table "foo"
-- >
-- > getAllBars :: Query s (Col s Text)
-- > getAllBars = do
-- >   t <- select fooTable
-- >   return (t ! field @"bar")
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