{-# 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.Typeable (Proxy (..), TypeRep)
import Database.GP.TypeInfo
import Database.HDBC (SqlValue)
import GHC.Generics
import GHC.TypeNats
import Database.GP.Conn
import Data.List (elemIndex)
class (Generic a, HasConstructor (Rep a), HasSelectors (Rep a)) => Entity a where
fromRow :: Conn -> [SqlValue] -> IO a
toRow :: Conn -> a -> IO [SqlValue]
idField :: String
fieldsToColumns :: [(String, String)]
tableName :: String
autoIncrement :: Bool
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
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
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"
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))
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)
default autoIncrement :: Bool
autoIncrement = Bool
True
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))
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)
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)
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
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