{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
  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
-}
module Database.PostgreSQL.Entity.Types
  ( -- * The /Entity/ Typeclass
    Entity (..)

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

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

    -- * DerivingVia Options
  , GenericEntity (..)
  , EntityOptions (..)
  , PrimaryKey
  , Schema
  , TableName
  , FieldModifiers
  , TextModifier (..)
  , StripPrefix
  , CamelTo
  , CamelToSnake
  , CamelToKebab
  )
where

import Data.Char
import Data.Kind
import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Display (Display, ShowInstance (..))
import qualified Data.Text.Manipulate as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector as Vector
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 = forall (e :: * -> *). GetTableName e => Options -> Text
getTableName @(Rep e) Options
defaultEntityOptions

  -- | The name of the schema; will be appended to the table name: schema."tablename"
  schema :: Maybe Text
  schema = forall a. Maybe a
Nothing

  -- | The name of the primary key for the table.
  primaryKey :: Field
  default primaryKey :: (GetFields (Rep e)) => Field
  primaryKey = Field
newPrimaryKey
    where
      primMod :: Text -> Text
primMod = Options -> Text -> Text
primaryKeyModifiers Options
defaultEntityOptions
      fs :: Vector Field
fs = forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) Options
defaultEntityOptions
      newPrimaryKey :: Field
newPrimaryKey =
        case forall a. (a -> Bool) -> Vector a -> Maybe a
Vector.find (\(Field Text
name Maybe Text
_type) -> Text
name forall a. Eq a => a -> a -> Bool
== Text -> Text
primMod Text
name) Vector Field
fs of
          Maybe Field
Nothing -> Text -> Maybe Text -> Field
Field (Text -> Text
primMod Text
"") forall a. Maybe a
Nothing
          Just Field
f -> Field
f

  -- | The fields of the table.
  fields :: Vector Field
  default fields :: (GetFields (Rep e)) => Vector Field
  fields = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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:tableNameModifiers:Options :: Options -> Text -> Text
tableNameModifiers :: Text -> Text
tableNameModifiers, Text -> Text
$sel:fieldModifiers:Options :: Options -> Text -> Text
fieldModifiers :: Text -> Text
fieldModifiers} = Text -> Text
tableNameModifiers forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldModifiers forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (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 = 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 = 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 = 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 = 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 = forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @e Options
opts forall a. Semigroup a => a -> a -> a
<> 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 = 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 = 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
fieldModifiers :: Text -> Text
$sel:fieldModifiers:Options :: Options -> Text -> Text
fieldModifiers} = forall a. a -> Vector a
V.singleton forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Field
Field Text
fieldName' forall a. Maybe a
Nothing
    where
      fieldName' :: Text
fieldName' = Text -> Text
fieldModifiers forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
Proxy @name)

-- Deriving Via machinery

newtype GenericEntity t e = GenericEntity {forall {k} (t :: k) e. GenericEntity t e -> e
getGenericEntity :: e}

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

  schema :: Maybe Text
schema = Options -> Maybe Text
schemaModifier (forall {k} (xs :: k). EntityOptions xs => Options
entityOptions @t)

  primaryKey :: Field
primaryKey = Field
newPrimaryKey
    where
      primMod :: Text -> Text
primMod = Options -> Text -> Text
primaryKeyModifiers (forall {k} (xs :: k). EntityOptions xs => Options
entityOptions @t)
      fs :: Vector Field
fs = forall (e :: * -> *). GetFields e => Options -> Vector Field
getField @(Rep e) (forall {k} (xs :: k). EntityOptions xs => Options
entityOptions @t)
      newPrimaryKey :: Field
newPrimaryKey =
        case forall a. (a -> Bool) -> Vector a -> Maybe a
Vector.find (\(Field Text
name Maybe Text
_type) -> Text
name forall a. Eq a => a -> a -> Bool
== Text -> Text
primMod Text
name) Vector Field
fs of
          Maybe Field
Nothing -> Text -> Maybe Text -> Field
Field (Text -> Text
primMod Text
"") forall a. Maybe a
Nothing
          Just Field
f -> Field
f

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

-- | Term-level options
data Options = Options
  { Options -> Text -> Text
tableNameModifiers :: Text -> Text
  , Options -> Maybe Text
schemaModifier :: Maybe Text
  , Options -> Text -> Text
primaryKeyModifiers :: Text -> Text
  , Options -> Text -> Text
fieldModifiers :: Text -> Text
  }

defaultEntityOptions :: Options
defaultEntityOptions :: Options
defaultEntityOptions =
  Options
    { $sel:tableNameModifiers:Options :: Text -> Text
tableNameModifiers = Text -> Text
T.toSnake
    , $sel:schemaModifier:Options :: Maybe Text
schemaModifier = forall a. Maybe a
Nothing
    , $sel:primaryKeyModifiers:Options :: Text -> Text
primaryKeyModifiers = Text -> Text
T.toSnake
    , $sel:fieldModifiers:Options :: Text -> Text
fieldModifiers = 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 = (forall {k} (xs :: k). EntityOptions xs => Options
entityOptions @xs){$sel:tableNameModifiers:Options :: Text -> Text
tableNameModifiers = forall a b. a -> b -> a
const (forall {k} (name :: k). GetName name => Text
getName @name)}

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

instance (TextModifier mods, EntityOptions xs) => EntityOptions (FieldModifiers mods ': xs) where
  entityOptions :: Options
entityOptions = (forall {k} (xs :: k). EntityOptions xs => Options
entityOptions @xs){$sel:fieldModifiers:Options :: Text -> Text
fieldModifiers = forall {k} (t :: k). TextModifier t => Text -> Text
getTextModifier @mods}

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

data TableName (t :: Symbol)

data PrimaryKey (t :: Symbol)

data Schema (t :: Symbol)

-- | Contains a list of 'TextModifiers' modifiers
data FieldModifiers ms

-- | 'TextModifier' to remove a certain prefix from the fields
data StripPrefix (prefix :: Symbol)

-- | 'FieldModifier' taking a separator Char when transforming from CamelCase.
data CamelTo (separator :: Symbol)

-- | CamelCase to snake_case
type CamelToSnake = CamelTo "_"

-- | CamelCase to kebab-case
type CamelToKebab = CamelTo "-"

{-| The modifiers that you can apply to the fields:

 * 'StripPrefix'
 * 'CamelTo', and its variations
   * 'CamelToSnake'
   * 'CamelToKebab'
-}
class TextModifier t where
  getTextModifier :: Text -> Text

--  No modifier
instance TextModifier '[] where
  getTextModifier :: Text -> Text
getTextModifier = forall a. a -> a
id

-- How we can have multiple modifiers chained
instance (TextModifier x, TextModifier xs) => TextModifier (x ': xs) where
  getTextModifier :: Text -> Text
getTextModifier = forall {k} (t :: k). TextModifier t => Text -> Text
getTextModifier @xs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k). TextModifier t => Text -> Text
getTextModifier @x

instance (KnownSymbol prefix) => TextModifier (StripPrefix prefix) where
  getTextModifier :: Text -> Text
getTextModifier Text
fld = forall a. a -> Maybe a -> a
fromMaybe Text
fld (Text -> Text -> Maybe Text
T.stripPrefix Text
prefixToStrip Text
fld)
    where
      prefixToStrip :: Text
prefixToStrip = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
Proxy @prefix)

instance (KnownSymbol separator, NonEmptyText separator) => TextModifier (CamelTo separator) where
  getTextModifier :: Text -> Text
getTextModifier Text
fld = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Char -> [Char] -> [Char]
camelTo2 Char
char (Text -> [Char]
T.unpack Text
fld)
    where
      char :: Char
      char :: Char
char = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (forall {k} (t :: k). Proxy t
Proxy @separator)
      camelTo2 :: Char -> String -> String
      camelTo2 :: Char -> [Char] -> [Char]
camelTo2 Char
c [Char]
text = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
go2 forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
go1 [Char]
text
        where
          go1 :: [Char] -> [Char]
go1 [Char]
"" = [Char]
""
          go1 (Char
x : Char
u : Char
l : [Char]
xs) | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l = Char
x forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: Char
u forall a. a -> [a] -> [a]
: Char
l forall a. a -> [a] -> [a]
: [Char] -> [Char]
go1 [Char]
xs
          go1 (Char
x : [Char]
xs) = Char
x forall a. a -> [a] -> [a]
: [Char] -> [Char]
go1 [Char]
xs
          go2 :: [Char] -> [Char]
go2 [Char]
"" = [Char]
""
          go2 (Char
l : Char
u : [Char]
xs) | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u = Char
l forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: Char
u forall a. a -> [a] -> [a]
: [Char] -> [Char]
go2 [Char]
xs
          go2 (Char
x : [Char]
xs) = Char
x forall a. a -> [a] -> [a]
: [Char] -> [Char]
go2 [Char]
xs

class GetName name where
  getName :: Text

instance (KnownSymbol name, NonEmptyText name) => GetName name where
  getName :: Text
getName = [Char] -> Text
T.pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (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 {forall a. UpdateRow a -> a
getUpdate :: a}
  deriving stock (UpdateRow a -> UpdateRow a -> Bool
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 -> [Char] -> [Char]
forall a. Show a => Int -> UpdateRow a -> [Char] -> [Char]
forall a. Show a => [UpdateRow a] -> [Char] -> [Char]
forall a. Show a => UpdateRow a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [UpdateRow a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [UpdateRow a] -> [Char] -> [Char]
show :: UpdateRow a -> [Char]
$cshow :: forall a. Show a => UpdateRow a -> [Char]
showsPrec :: Int -> UpdateRow a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> UpdateRow a -> [Char] -> [Char]
Show)
  deriving newtype (Maybe Text
Text
Vector Field
Field
forall e. Text -> Maybe Text -> Field -> Vector Field -> Entity e
forall a. Entity a => Maybe Text
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
schema :: Maybe Text
$cschema :: forall a. Entity a => Maybe Text
tableName :: Text
$ctableName :: forall a. Entity a => Text
Entity)

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

{-|
 @since 0.0.2.0
-}
data SortKeyword = ASC | DESC
  deriving stock (SortKeyword -> SortKeyword -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SortKeyword -> SortKeyword -> Bool
$c/= :: SortKeyword -> SortKeyword -> Bool
== :: SortKeyword -> SortKeyword -> Bool
$c== :: SortKeyword -> SortKeyword -> Bool
Eq, Int -> SortKeyword -> [Char] -> [Char]
[SortKeyword] -> [Char] -> [Char]
SortKeyword -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [SortKeyword] -> [Char] -> [Char]
$cshowList :: [SortKeyword] -> [Char] -> [Char]
show :: SortKeyword -> [Char]
$cshow :: SortKeyword -> [Char]
showsPrec :: Int -> SortKeyword -> [Char] -> [Char]
$cshowsPrec :: Int -> SortKeyword -> [Char] -> [Char]
Show)
  deriving
    (Int -> SortKeyword -> Builder
[SortKeyword] -> Builder
SortKeyword -> Builder
forall a.
(a -> Builder)
-> ([a] -> Builder) -> (Int -> a -> Builder) -> Display a
displayPrec :: Int -> SortKeyword -> Builder
$cdisplayPrec :: Int -> SortKeyword -> Builder
displayList :: [SortKeyword] -> Builder
$cdisplayList :: [SortKeyword] -> Builder
displayBuilder :: SortKeyword -> Builder
$cdisplayBuilder :: SortKeyword -> Builder
Display)
    via ShowInstance SortKeyword