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

module Database.GP.Entity
  ( Entity (..),
    columnNameFor,
    toString,
    EntityId,
    gtoRow,
    GToRow,
    GFromRow,
    maybeFieldTypeFor,
    Conn(..),
    Database(..),
  )
where

import           Data.Char            (toLower)
import           Data.Convertible
import           Data.Kind
import           Data.Typeable        (Proxy (..), TypeRep)
import           Database.GP.TypeInfo
import           Database.HDBC        (SqlValue)
import           GHC.Generics
import           GHC.TypeNats
import           Generics.Deriving.Show (GShow' (..), gshowsPrecdefault)
import           Database.GP.Conn

{- | 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, compund 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

  -- | fromRow generic default implementation
  default fromRow :: (GFromRow (Rep a)) => Conn -> [SqlValue] -> IO a
  fromRow Conn
_conn = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = String
idFieldName
    where
      idFieldName :: String
      idFieldName :: String
idFieldName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall {k} (a :: k). TypeInfo a -> String
constructorName TypeInfo a
ti) forall a. [a] -> [a] -> [a]
++ String
"ID"
      ti :: TypeInfo a
ti = forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo @a

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

-- | The EntityId is a tuple of the constructor name and the primary key value of an Entity.
type EntityId = (String, SqlValue)

-- | 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 ->
      forall a. HasCallStack => String -> a
error
        ( String
"columnNameFor: "
            forall a. [a] -> [a] -> [a]
++ forall a. Entity a => String
tableName @a
            forall a. [a] -> [a] -> [a]
++ String
" has no column mapping for "
            forall a. [a] -> [a] -> [a]
++ String
fieldName
        )
  where
    maybeColumnNameFor :: String -> Maybe String
    maybeColumnNameFor :: String -> Maybe String
maybeColumnNameFor String
field = 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 = 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 = forall a b. [a] -> [b] -> [(a, b)]
zip (forall {k} (a :: k). TypeInfo a -> [String]
fieldNames TypeInfo a
ti) (forall {k} (a :: k). TypeInfo a -> [TypeRep]
fieldTypes TypeInfo a
ti)

-- | Returns a string representation of a value of type 'a'.
toString :: forall a. (Generic a, GShow' (Rep a)) => a -> String
toString :: forall a. (Generic a, GShow' (Rep a)) => a -> String
toString = a -> String
gshow
  where
    gshows :: a -> ShowS
    gshows :: a -> String -> String
gshows = forall a.
(Generic a, GShow' (Rep a)) =>
Int -> a -> String -> String
gshowsPrecdefault Int
0

    gshow :: a -> String
    gshow :: a -> String
gshow a
x = a -> String -> String
gshows a
x String
""

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

instance GToRow U1 where
  gtoRow :: forall (a :: k). U1 a -> [SqlValue]
gtoRow U1 a
U1 = forall a. Monoid a => a
mempty

instance (Convertible a SqlValue) => GToRow (K1 i a) where
  gtoRow :: forall (a :: k). K1 i a a -> [SqlValue]
gtoRow (K1 a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) = forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow a a
a forall a. Monoid a => a -> a -> a
`mappend` 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) = forall {k} (f :: k -> *) (a :: k). GToRow f => f a -> [SqlValue]
gtoRow a a
a

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

instance GFromRow U1 where
  gfromRow :: forall (a :: k). [SqlValue] -> U1 a
gfromRow = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

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

instance GFromRow a => GFromRow (M1 i c a) where
  gfromRow :: forall (a :: k). [SqlValue] -> M1 i c a a
gfromRow = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow [SqlValue]
rowf forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall {k} (f :: k -> *) (a :: k). GFromRow f => [SqlValue] -> f a
gfromRow [SqlValue]
rowg
    where
      ([SqlValue]
rowf, [SqlValue]
rowg) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
fNumFields [SqlValue]
row
      fNumFields :: Int
fNumFields = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (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