{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Database.GP.Entity
  ( Entity (..),
    columnNameFor,
    gtoRow,
    GToRow,
    GFromRow,
    maybeFieldTypeFor,
    Conn (..),
    TxHandling (..),
    maybeIdFieldIndex,
    fieldIndex,
  )
where

import           Data.Char            (toLower)
import           Data.Convertible
import           Data.Kind
import           Data.List            (elemIndex)
import           Data.Typeable        (Proxy (..), TypeRep)
import           Database.GP.Conn
import           Database.GP.TypeInfo
import           Database.HDBC        (SqlValue)
import           GHC.Generics
import           GHC.TypeNats

-- | This is the Entity class. It is a type class that is used to define the mapping
-- between a Haskell product type in record notation and a database table.
-- The class has a default implementation for all methods.
-- The default implementation uses the type information to determine a simple 1:1 mapping.
--
-- That means that
-- - the type name is used as the table name and the
-- - field names are used as the column names.
-- - A field named '<lowercase typeName>ID' is used as the primary key field.
--
-- The default implementation can be overridden by defining a custom instance for a type.
--
-- Please note the following constraints, which apply to all valid Entity type,
-- but that are not explicitely encoded in the type class definition:
--
-- - The type must be a product type in record notation.
-- - The type must have exactly one constructor.
-- - There must be single primary key field, compound primary keys are not supported.
class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where
  -- | Converts a database row to a value of type 'a'.
  fromRow :: Conn -> [SqlValue] -> IO a

  -- | Converts a value of type 'a' to a database row.
  toRow :: Conn -> a -> IO [SqlValue]

  -- | Returns the name of the primary key field for a type 'a'.
  idField :: String

  -- | Returns a list of tuples that map field names to column names for a type 'a'.
  fieldsToColumns :: [(String, String)]

  -- | Returns the name of the table for a type 'a'.
  tableName :: String

  -- | Returns True if the primary key field for a type 'a' is autoincremented by the database.
  autoIncrement :: Bool

  -- | fromRow generic default implementation
  default fromRow :: (GFromRow (Rep a)) => Conn -> [SqlValue] -> IO a
  fromRow Conn
_conn = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> (Rep a Any -> a) -> Rep a Any -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> IO a)
-> ([SqlValue] -> Rep a Any) -> [SqlValue] -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SqlValue] -> Rep a Any
forall a. [SqlValue] -> Rep a a
forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow

  -- | toRow generic default implementation
  default toRow :: GToRow (Rep a) => Conn -> a -> IO [SqlValue]
  toRow Conn
_ = [SqlValue] -> IO [SqlValue]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SqlValue] -> IO [SqlValue])
-> (a -> [SqlValue]) -> a -> IO [SqlValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> [SqlValue]
forall a. Rep a a -> [SqlValue]
forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow (Rep a Any -> [SqlValue]) -> (a -> Rep a Any) -> a -> [SqlValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

  -- | idField default implementation: the ID field is the field with the same name
  --   as the type name in lower case and appended with "ID", e.g. "bookID"
  default idField :: String
  idField = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (TypeInfo a -> String
forall {k} (a :: k). TypeInfo a -> String
constructorName (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ID"

  -- | fieldsToColumns default implementation: the field names are used as column names
  default fieldsToColumns :: [(String, String)]
  fieldsToColumns = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TypeInfo a -> [String]
forall {k} (a :: k). TypeInfo a -> [String]
fieldNames (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a)) (TypeInfo a -> [String]
forall {k} (a :: k). TypeInfo a -> [String]
fieldNames (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a))

  -- | tableName default implementation: the type name is used as table name
  default tableName :: String
  tableName = TypeInfo a -> String
forall {k} (a :: k). TypeInfo a -> String
constructorName (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a)

  -- | autoIncrement default implementation: the ID field is autoincremented
  default autoIncrement :: Bool
  autoIncrement = Bool
True

-- | Returns Just index of the primary key field for a type 'a'.
--   if the type has no primary key field, Nothing is returned.
maybeIdFieldIndex :: forall a. (Entity a) => Maybe Int
maybeIdFieldIndex :: forall a. Entity a => Maybe Int
maybeIdFieldIndex = String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (forall a. Entity a => String
idField @a) (TypeInfo a -> [String]
forall {k} (a :: k). TypeInfo a -> [String]
fieldNames (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a))

-- | returns the index of a field of an entity.
--   The index is the position of the field in the list of fields of the entity.
--   If no such field exists, an error is thrown.
--   The function takes an field name as parameters,
--   the type of the entity is determined by the context.
fieldIndex :: forall a. (Entity a) => String -> Int
fieldIndex :: forall a. Entity a => String -> Int
fieldIndex String
fieldName =
  String -> Maybe Int -> Int
forall a. String -> Maybe a -> a
expectJust
    (String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not present in type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeInfo a -> String
forall {k} (a :: k). TypeInfo a -> String
constructorName TypeInfo a
ti)
    (String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
fieldName [String]
fieldList)
  where
    ti :: TypeInfo a
ti = forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a
    fieldList :: [String]
fieldList = TypeInfo a -> [String]
forall {k} (a :: k). TypeInfo a -> [String]
fieldNames TypeInfo a
ti

expectJust :: String -> Maybe a -> a
expectJust :: forall a. String -> Maybe a -> a
expectJust String
_ (Just a
x)  = a
x
expectJust String
err Maybe a
Nothing = String -> a
forall a. HasCallStack => String -> a
error (String
"expectJust " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)

-- | A convenience function: returns the name of the column for a field of a type 'a'.
columnNameFor :: forall a. (Entity a) => String -> String
columnNameFor :: forall a. Entity a => String -> String
columnNameFor String
fieldName =
  case String -> Maybe String
maybeColumnNameFor String
fieldName of
    Just String
columnName -> String
columnName
    Maybe String
Nothing ->
      String -> String
forall a. HasCallStack => String -> a
error
        ( String
"columnNameFor: "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ forall a. Entity a => String
tableName @a
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no column mapping for "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fieldName
        )
  where
    maybeColumnNameFor :: String -> Maybe String
    maybeColumnNameFor :: String -> Maybe String
maybeColumnNameFor String
field = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
field (forall a. Entity a => [(String, String)]
fieldsToColumns @a)

maybeFieldTypeFor :: forall a. (Entity a) => String -> Maybe TypeRep
maybeFieldTypeFor :: forall a. Entity a => String -> Maybe TypeRep
maybeFieldTypeFor String
field = String -> [(String, TypeRep)] -> Maybe TypeRep
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
field (TypeInfo a -> [(String, TypeRep)]
fieldsAndTypes (forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a))
  where
    fieldsAndTypes :: TypeInfo a -> [(String, TypeRep)]
    fieldsAndTypes :: TypeInfo a -> [(String, TypeRep)]
fieldsAndTypes TypeInfo a
ti = [String] -> [TypeRep] -> [(String, TypeRep)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TypeInfo a -> [String]
forall {k} (a :: k). TypeInfo a -> [String]
fieldNames TypeInfo a
ti) (TypeInfo a -> [TypeRep]
forall {k} (a :: k). TypeInfo a -> [TypeRep]
fieldTypes TypeInfo a
ti)

-- generics based implementations for gFromRow and gToRow
class GToRow f where
  gtoRow :: f a -> [SqlValue]

instance (Convertible a SqlValue) => GToRow (K1 i a) where
  gtoRow :: forall (a :: k). K1 i a a -> [SqlValue]
gtoRow (K1 a
a) = SqlValue -> [SqlValue]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SqlValue -> [SqlValue]) -> SqlValue -> [SqlValue]
forall a b. (a -> b) -> a -> b
$ a -> SqlValue
forall a b. Convertible a b => a -> b
convert a
a

instance (GToRow a, GToRow b) => GToRow (a :*: b) where
  gtoRow :: forall (a :: k). (:*:) a b a -> [SqlValue]
gtoRow (a a
a :*: b a
b) = a a -> [SqlValue]
forall (a :: k). a a -> [SqlValue]
forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow a a
a [SqlValue] -> [SqlValue] -> [SqlValue]
forall a. Monoid a => a -> a -> a
`mappend` b a -> [SqlValue]
forall (a :: k). b a -> [SqlValue]
forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow b a
b

instance GToRow a => GToRow (M1 i c a) where
  gtoRow :: forall (a :: k). M1 i c a a -> [SqlValue]
gtoRow (M1 a a
a) = a a -> [SqlValue]
forall (a :: k). a a -> [SqlValue]
forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow a a
a

class GFromRow f where
  gfromRow :: [SqlValue] -> f a

instance (Convertible SqlValue a) => GFromRow (K1 i a) where
  gfromRow :: forall (a :: k). [SqlValue] -> K1 i a a
gfromRow = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> ([SqlValue] -> a) -> [SqlValue] -> K1 i a a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlValue -> a
forall a b. Convertible a b => a -> b
convert (SqlValue -> a) -> ([SqlValue] -> SqlValue) -> [SqlValue] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SqlValue] -> SqlValue
forall a. HasCallStack => [a] -> a
head

instance GFromRow a => GFromRow (M1 i c a) where
  gfromRow :: forall (a :: k). [SqlValue] -> M1 i c a a
gfromRow = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a)
-> ([SqlValue] -> a a) -> [SqlValue] -> M1 i c a a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SqlValue] -> a a
forall (a :: k). [SqlValue] -> a a
forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow

-- | This instance is the most interesting one. It splits the list of
-- 'SqlValue's into two parts, one for the first field and one for the
-- rest. Then it uses the 'GFromRow' instance for the first field to
-- convert the first part of the list and the 'GFromRow' instance for
-- the rest of the fields to convert the second part of the list.
-- Finally, it combines the two results using the ':*:' constructor.
-- https://stackoverflow.com/questions/75485429/how-to-use-ghc-generics-to-convert-from-product-data-types-to-a-list-of-sqlvalue/75485650#75485650
instance (KnownNat (NumFields f), GFromRow f, GFromRow g) => GFromRow (f :*: g) where
  gfromRow :: forall a. [SqlValue] -> (:*:) f g a
gfromRow [SqlValue]
row = [SqlValue] -> f a
forall a. [SqlValue] -> f a
forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow [SqlValue]
rowf f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: [SqlValue] -> g a
forall a. [SqlValue] -> g a
forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow [SqlValue]
rowg
    where
      ([SqlValue]
rowf, [SqlValue]
rowg) = Int -> [SqlValue] -> ([SqlValue], [SqlValue])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
fNumFields [SqlValue]
row
      fNumFields :: Int
fNumFields = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (NumFields f) -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy (NumFields f)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (NumFields f)))

type family NumFields (f :: Type -> Type) :: Nat where
  NumFields (M1 i c f) = 1
  NumFields (f :*: g) = NumFields f + NumFields g