{-|
  Module      : Database.PostgreSQL.Entity.Types
  Copyright   : © Clément Delafargue, 2018
                  Théophile Choutri, 2021
  License     : MIT
  Maintainer  : theophile@choutri.eu
  Stability   : stable

  Types and classes

-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.PostgreSQL.Entity.Types
  (
    -- * The /Entity/ Typeclass
    Entity (..)

    -- * Associated Types
  , Field
  , field
  , fieldName
  , fieldType
  , UpdateRow(..)

    -- * Generics
  , Options(..)
  , defaultEntityOptions

    -- * DerivingVia Options
  , GenericEntity(..)
  , EntityOptions(..)
  , PrimaryKey
  , TableName
  ) where

import Data.Kind
import Data.Proxy
import Data.Text (Text, pack)
import qualified Data.Text.Manipulate as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import Database.PostgreSQL.Entity.Internal.QQ (field)
import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))
import Database.PostgreSQL.Simple.ToRow (ToRow (..))
import GHC.Generics
import GHC.TypeLits

-- | An 'Entity' stores the following information about the structure of a database table:
--
-- * Its name
-- * Its primary key
-- * The fields it contains
--
-- == Example
--
-- > data ExampleEntity = E
-- >   { key    :: Key
-- >   , field1 :: Int
-- >   , field2 :: Bool
-- >   }
-- >   deriving stock (Eq, Show, Generic)
-- >   deriving anyclass (FromRow, ToRow)
-- >   deriving Entity
-- >      via (GenericEntity '[TableName "entities"] ExampleEntity)
--
-- When using the functions provided by this library, you will sometimes need to be explicit about the Entity you are
-- referring to.
--
-- @since 0.0.1.0
class Entity e where
  -- | The name of the table in the PostgreSQL database.
  tableName :: Text
  default tableName :: (GetTableName (Rep e)) => Text
  tableName = Options -> Text
forall (e :: * -> *). GetTableName e => Options -> Text
getTableName @(Rep e) Options
defaultEntityOptions
  -- | The name of the primary key for the table.
  primaryKey :: Field
  default primaryKey :: (GetFields (Rep e)) => Field
  primaryKey = Text -> Maybe Text -> Field
Field (Text -> Text
primMod Text
name) Maybe Text
typ
    where primMod :: Text -> Text
primMod = Options -> Text -> Text
primaryKeyModifier Options
defaultEntityOptions
          Field Text
name Maybe Text
typ = Vector Field -> Field
forall a. Vector a -> a
V.head (Vector Field -> Field) -> Vector Field -> Field
forall a b. (a -> b) -> a -> b
$ Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) Options
defaultEntityOptions
  -- | The fields of the table.
  fields :: Vector Field
  default fields :: (GetFields (Rep e)) => Vector Field
  fields = Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) Options
defaultEntityOptions

-- The sub-class that fetches the table name
class GetTableName (e :: Type -> Type) where
  getTableName :: Options -> Text

instance (TypeError ('Text "You can't derive Entity for a void type")) => GetTableName V1 where
  getTableName :: Options -> Text
getTableName Options
_opts = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a void type"

instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetTableName U1 where
  getTableName :: Options -> Text
getTableName Options
_opts = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a unit type"

instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetTableName (e :+: f) where
  getTableName :: Options -> Text
getTableName Options
_opts = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a sum type"

instance (TypeError ('Text "You can't derive an Entity for a type constructor's field")) => GetTableName (K1 i c) where
  getTableName :: Options -> Text
getTableName Options
_opts = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a type constructor's field"

instance (TypeError ('Text "You don't have to derive GetTableName for a product type")) => GetTableName (e :*: f) where
  getTableName :: Options -> Text
getTableName Options
_opts = [Char] -> Text
forall a. HasCallStack => [Char] -> a
error [Char]
"You don't have to derive GetTableName for a product type"

instance GetTableName e => GetTableName (M1 C _1 e) where
  getTableName :: Options -> Text
getTableName Options
opts = Options -> Text
forall (e :: * -> *). GetTableName e => Options -> Text
getTableName @e Options
opts

instance GetTableName e => GetTableName (M1 S _1 e) where
  getTableName :: Options -> Text
getTableName Options
opts = Options -> Text
forall (e :: * -> *). GetTableName e => Options -> Text
getTableName @e Options
opts

instance (KnownSymbol name)
    => GetTableName (M1 D ('MetaData name _1 _2 _3) e) where
  getTableName :: Options -> Text
getTableName Options{Text -> Text
$sel:tableNameModifier:Options :: Options -> Text -> Text
tableNameModifier :: Text -> Text
tableNameModifier} = Text -> Text
tableNameModifier (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)

-- The sub-class that fetches the table fields
class GetFields (e :: Type -> Type) where
  getField :: Options -> Vector Field

instance (TypeError ('Text "You can't derive Entity for a void type")) => GetFields V1 where
  getField :: Options -> Vector Field
getField Options
_opts = [Char] -> Vector Field
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a void type"

instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetFields U1 where
  getField :: Options -> Vector Field
getField Options
_opts = [Char] -> Vector Field
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a unit type"

instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetFields (e :+: f) where
  getField :: Options -> Vector Field
getField Options
_opts = [Char] -> Vector Field
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a sum type"

instance (TypeError ('Text "You can't derive Entity for a a type constructor's field")) => GetFields (K1 i c) where
  getField :: Options -> Vector Field
getField Options
_opts = [Char] -> Vector Field
forall a. HasCallStack => [Char] -> a
error [Char]
"You can't derive Entity for a type constructor's field"

instance (GetFields e, GetFields f) => GetFields (e :*: f) where
  getField :: Options -> Vector Field
getField Options
opts = Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @e Options
opts Vector Field -> Vector Field -> Vector Field
forall a. Semigroup a => a -> a -> a
<> Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @f Options
opts

instance GetFields e => GetFields (M1 C _1 e) where
  getField :: Options -> Vector Field
getField Options
opts = Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @e Options
opts

instance GetFields e => GetFields (M1 D ('MetaData _1 _2 _3 _4) e) where
  getField :: Options -> Vector Field
getField Options
opts = Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @e Options
opts

instance (KnownSymbol name) => GetFields (M1 S ('MetaSel ('Just name) _1 _2 _3) _4) where
  getField :: Options -> Vector Field
getField Options{Text -> Text
$sel:fieldModifier:Options :: Options -> Text -> Text
fieldModifier :: Text -> Text
fieldModifier} = Field -> Vector Field
forall a. a -> Vector a
V.singleton (Field -> Vector Field) -> Field -> Vector Field
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Field
Field Text
fieldName' Maybe Text
forall a. Maybe a
Nothing
    where fieldName' :: Text
fieldName' = Text -> Text
fieldModifier (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name)

-- Deriving Via machinery

newtype GenericEntity t e
  = GenericEntity { GenericEntity t e -> e
getGenericEntity :: e }

instance (EntityOptions t, GetTableName (Rep e), GetFields (Rep e)) => Entity (GenericEntity t e) where
  tableName :: Text
tableName = Options -> Text
forall (e :: * -> *). GetTableName e => Options -> Text
getTableName @(Rep e) (EntityOptions t => Options
forall k (xs :: k). EntityOptions xs => Options
entityOptions @t)

  primaryKey :: Field
primaryKey = Text -> Maybe Text -> Field
Field (Text -> Text
primMod Text
name) Maybe Text
typ
    where primMod :: Text -> Text
primMod = Options -> Text -> Text
primaryKeyModifier Options
defaultEntityOptions
          Field Text
name Maybe Text
typ = Vector Field -> Field
forall a. Vector a -> a
V.head (Vector Field -> Field) -> Vector Field -> Field
forall a b. (a -> b) -> a -> b
$ Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) (EntityOptions t => Options
forall k (xs :: k). EntityOptions xs => Options
entityOptions @t)

  fields :: Vector Field
fields = Options -> Vector Field
forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) (EntityOptions t => Options
forall k (xs :: k). EntityOptions xs => Options
entityOptions @t)

-- | Term-level options
data Options
  = Options { Options -> Text -> Text
tableNameModifier  :: Text -> Text
            , Options -> Text -> Text
primaryKeyModifier :: Text -> Text
            , Options -> Text -> Text
fieldModifier      :: Text -> Text
            }

defaultEntityOptions :: Options
defaultEntityOptions :: Options
defaultEntityOptions = (Text -> Text) -> (Text -> Text) -> (Text -> Text) -> Options
Options Text -> Text
T.toSnake Text -> Text
T.toSnake Text -> Text
T.toSnake

-- | Type-level options for Deriving Via
class EntityOptions xs where
  entityOptions :: Options

instance EntityOptions '[] where
  entityOptions :: Options
entityOptions = Options
defaultEntityOptions

instance (GetName name, EntityOptions xs) => EntityOptions (TableName name ': xs) where
  entityOptions :: Options
entityOptions = (EntityOptions xs => Options
forall k (xs :: k). EntityOptions xs => Options
entityOptions @xs){$sel:tableNameModifier:Options :: Text -> Text
tableNameModifier = Text -> Text -> Text
forall a b. a -> b -> a
const (GetName name => Text
forall k (name :: k). GetName name => Text
getName @name)}

instance (GetName name, EntityOptions xs) => EntityOptions (PrimaryKey name ': xs) where
  entityOptions :: Options
entityOptions = (EntityOptions xs => Options
forall k (xs :: k). EntityOptions xs => Options
entityOptions @xs){$sel:primaryKeyModifier:Options :: Text -> Text
primaryKeyModifier = Text -> Text -> Text
forall a b. a -> b -> a
const (GetName name => Text
forall k (name :: k). GetName name => Text
getName @name)}

data TableName t

data PrimaryKey t

class GetName name where
  getName :: Text

instance (KnownSymbol name, NonEmptyText name) => GetName name where
  getName :: Text
getName = [Char] -> Text
pack (Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy @name))

type family NonEmptyText (xs :: Symbol) :: Constraint where
  NonEmptyText "" = TypeError ('Text "User-provided string cannot be empty!")
  NonEmptyText _  = ()

-- | Get the name of a field.
--
-- @since 0.1.0.0
fieldName :: Field -> Text
fieldName :: Field -> Text
fieldName (Field Text
name Maybe Text
_) = Text
name

-- | Get the type of a field, if any.
--
-- @since 0.1.0.0
fieldType :: Field -> Maybe Text
fieldType :: Field -> Maybe Text
fieldType (Field Text
_ Maybe Text
typ) = Maybe Text
typ

-- | Wrapper used by the update function in order to have the primary key as the last parameter passed,
-- since it appears in the WHERE clause.
--
-- @since 0.0.1.0
newtype UpdateRow a
  = UpdateRow { UpdateRow a -> a
getUpdate :: a }
  deriving stock (UpdateRow a -> UpdateRow a -> Bool
(UpdateRow a -> UpdateRow a -> Bool)
-> (UpdateRow a -> UpdateRow a -> Bool) -> Eq (UpdateRow a)
forall a. Eq a => UpdateRow a -> UpdateRow a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpdateRow a -> UpdateRow a -> Bool
$c/= :: forall a. Eq a => UpdateRow a -> UpdateRow a -> Bool
== :: UpdateRow a -> UpdateRow a -> Bool
$c== :: forall a. Eq a => UpdateRow a -> UpdateRow a -> Bool
Eq, Int -> UpdateRow a -> ShowS
[UpdateRow a] -> ShowS
UpdateRow a -> [Char]
(Int -> UpdateRow a -> ShowS)
-> (UpdateRow a -> [Char])
-> ([UpdateRow a] -> ShowS)
-> Show (UpdateRow a)
forall a. Show a => Int -> UpdateRow a -> ShowS
forall a. Show a => [UpdateRow a] -> ShowS
forall a. Show a => UpdateRow a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UpdateRow a] -> ShowS
$cshowList :: forall a. Show a => [UpdateRow a] -> ShowS
show :: UpdateRow a -> [Char]
$cshow :: forall a. Show a => UpdateRow a -> [Char]
showsPrec :: Int -> UpdateRow a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> UpdateRow a -> ShowS
Show)
  deriving newtype (Text
Vector Field
Field
Text -> Field -> Vector Field -> Entity (UpdateRow a)
forall e. Text -> Field -> Vector Field -> Entity e
forall a. Entity a => Text
forall a. Entity a => Vector Field
forall a. Entity a => Field
fields :: Vector Field
$cfields :: forall a. Entity a => Vector Field
primaryKey :: Field
$cprimaryKey :: forall a. Entity a => Field
tableName :: Text
$ctableName :: forall a. Entity a => Text
Entity)

instance ToRow a => ToRow (UpdateRow a) where
  toRow :: UpdateRow a -> [Action]
toRow = (Int -> [Action] -> [Action]
forall a. Int -> [a] -> [a]
drop (Int -> [Action] -> [Action])
-> (Int -> [Action] -> [Action]) -> Int -> [Action] -> [Action]
forall a. Semigroup a => a -> a -> a
<> Int -> [Action] -> [Action]
forall a. Int -> [a] -> [a]
take) Int
1 ([Action] -> [Action])
-> (UpdateRow a -> [Action]) -> UpdateRow a -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Action]
forall a. ToRow a => a -> [Action]
toRow (a -> [Action]) -> (UpdateRow a -> a) -> UpdateRow a -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateRow a -> a
forall a. UpdateRow a -> a
getUpdate