{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}
{-# LANGUAGE GADTs, CPP, DataKinds #-}
module Database.Selda.Generic
( Relational, Generic
, tblCols, params, def, gNew, gRow
) where
import Control.Monad.State
( liftM2, MonadState(put, get), evalState, State )
import Data.Dynamic ( Typeable )
import Data.Text as Text (Text, pack)
import Data.Typeable ( Proxy(..), typeRep, typeRepTyCon )
import GHC.Generics
( Generic(from, Rep), Selector(selName), K1(K1), M1(M1), S )
import qualified GHC.Generics as G
( (:*:)(..), Selector, (:+:)(..) )
import qualified GHC.TypeLits as TL
import qualified Database.Selda.Column as C (Col)
import Control.Exception (Exception (..), try, throw)
import System.IO.Unsafe ( unsafePerformIO )
import Database.Selda.Types ( ColName, modColName, mkColName )
import Database.Selda.SqlType
( Lit, SqlType(sqlType, defaultValue, mkLit) )
import Database.Selda.SqlRow (SqlRow)
import Database.Selda.Table.Type
( ColAttr(Required, Optional), ColInfo(..) )
import Database.Selda.SQL (Param (..))
import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..))
type Relational a =
( Generic a
, SqlRow a
, GRelation (Rep a)
)
params :: Relational a => a -> [Either Param Param]
params :: forall a. Relational a => a -> [Either Param Param]
params = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from
tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols Proxy a
_ Text -> Text
fieldMod =
forall s a. State s a -> s -> a
evalState (forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep a)) forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename) Int
0
where
rename :: Int -> Maybe ColName -> ColName
rename Int
n Maybe ColName
Nothing = Text -> ColName
mkColName forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldMod (Text
"col_" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Int
n))
rename Int
_ (Just ColName
name) = ColName -> (Text -> Text) -> ColName
modColName ColName
name Text -> Text
fieldMod
data DefaultValueException = DefaultValueException
deriving Int -> DefaultValueException -> ShowS
[DefaultValueException] -> ShowS
DefaultValueException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultValueException] -> ShowS
$cshowList :: [DefaultValueException] -> ShowS
show :: DefaultValueException -> String
$cshow :: DefaultValueException -> String
showsPrec :: Int -> DefaultValueException -> ShowS
$cshowsPrec :: Int -> DefaultValueException -> ShowS
Show
instance Exception DefaultValueException
def :: SqlType a => a
def :: forall a. SqlType a => a
def = forall a e. Exception e => e -> a
throw DefaultValueException
DefaultValueException
class GRelation f where
gParams :: f a -> IO [Either Param Param]
gTblCols :: Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gNew :: Proxy f -> [UntypedCol sql]
gRow :: f a -> [UntypedCol sql]
instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where
gParams :: forall a. M1 t c a a -> IO [Either Param Param]
gParams (M1 a a
x) = forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
x
gTblCols :: Proxy (M1 t c a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (M1 t c a)
_ = forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
gNew :: forall sql. Proxy (M1 t c a) -> [UntypedCol sql]
gNew Proxy (M1 t c a)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
gRow :: forall a sql. M1 t c a a -> [UntypedCol sql]
gRow (M1 a a
x) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
x
instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) =>
GRelation (M1 S c a) where
gParams :: forall a. M1 S c a a -> IO [Either Param Param]
gParams (M1 a a
x) = forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
x
gTblCols :: Proxy (M1 S c a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (M1 S c a)
_ Maybe ColName
_ = forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Maybe ColName
name
where
name :: Maybe ColName
name =
case forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName ((forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a. HasCallStack => a
undefined) :: M1 S c a b) of
String
"" -> forall a. Maybe a
Nothing
String
s -> forall a. a -> Maybe a
Just (Text -> ColName
mkColName forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s)
gNew :: forall sql. Proxy (M1 S c a) -> [UntypedCol sql]
gNew Proxy (M1 S c a)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
gRow :: forall a sql. M1 S c a a -> [UntypedCol sql]
gRow (M1 a a
x) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
x
instance (Typeable a, SqlType a) => GRelation (K1 i a) where
gParams :: forall a. K1 i a a -> IO [Either Param Param]
gParams (K1 a
x) = do
Either DefaultValueException a
res <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
x
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either DefaultValueException a
res of
Right a
x' -> [forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Lit a -> Param
Param (forall a. SqlType a => a -> Lit a
mkLit a
x')]
Left DefaultValueException
DefaultValueException -> [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Lit a -> Param
Param (forall a. SqlType a => Lit a
defaultValue :: Lit a)]
gTblCols :: Proxy (K1 i a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (K1 i a)
_ Maybe ColName
name Int -> Maybe ColName -> ColName
rename = do
Int
n <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nforall a. Num a => a -> a -> a
+Int
1)
let name' :: ColName
name' = Int -> Maybe ColName -> ColName
rename Int
n Maybe ColName
name
forall (m :: * -> *) a. Monad m => a -> m a
return
[ ColInfo
{ colName :: ColName
colName = ColName
name'
, colType :: SqlTypeRep
colType = forall a. SqlType a => Proxy a -> SqlTypeRep
sqlType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
, colAttrs :: [ColAttr]
colAttrs = [ColAttr]
optReq
, colFKs :: [(Table (), ColName)]
colFKs = []
, colExpr :: UntypedCol SQL
colExpr = forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall sql a. ColName -> Exp sql a
Col ColName
name')
}
]
where
maybeTyCon :: TyCon
maybeTyCon = TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Maybe ())))
optReq :: [ColAttr]
optReq
| TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. Eq a => a -> a -> Bool
== TyCon
maybeTyCon = [ColAttr
Optional]
| Bool
otherwise = [ColAttr
Required]
gNew :: forall sql. Proxy (K1 i a) -> [UntypedCol sql]
gNew Proxy (K1 i a)
_ = [forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall a sql. Lit a -> Exp sql a
Lit (forall a. SqlType a => Lit a
defaultValue :: Lit a))]
gRow :: forall a sql. K1 i a a -> [UntypedCol sql]
gRow (K1 a
x) = [forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall a sql. Lit a -> Exp sql a
Lit (forall a. SqlType a => a -> Lit a
mkLit a
x))]
instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where
gParams :: forall a. (:*:) a b a -> IO [Either Param Param]
gParams (a a
a G.:*: b a
b) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
a) (forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams b a
b)
gTblCols :: Proxy (a :*: b)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (a :*: b)
_ Maybe ColName
_ Int -> Maybe ColName -> ColName
rename = do
[ColInfo]
as <- forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy a
a forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename
[ColInfo]
bs <- forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy b
b forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename
forall (m :: * -> *) a. Monad m => a -> m a
return ([ColInfo]
as forall a. [a] -> [a] -> [a]
++ [ColInfo]
bs)
where
a :: Proxy a
a = forall {k} (t :: k). Proxy t
Proxy :: Proxy a
b :: Proxy b
b = forall {k} (t :: k). Proxy t
Proxy :: Proxy b
gNew :: forall sql. Proxy (a :*: b) -> [UntypedCol sql]
gNew Proxy (a :*: b)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
gRow :: forall a sql. (:*:) a b a -> [UntypedCol sql]
gRow (a a
a G.:*: b a
b) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
a forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow b a
b
instance
(TL.TypeError
( 'TL.Text "Selda currently does not support creating tables from sum types."
'TL.:$$:
'TL.Text "Restrict your table type to a single data constructor."
)) => GRelation (a G.:+: b) where
gParams :: forall a. (:+:) a b a -> IO [Either Param Param]
gParams = forall a. HasCallStack => String -> a
error String
"unreachable"
gTblCols :: Proxy (a :+: b)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols = forall a. HasCallStack => String -> a
error String
"unreachable"
gNew :: forall sql. Proxy (a :+: b) -> [UntypedCol sql]
gNew = forall a. HasCallStack => String -> a
error String
"unreachable"
gRow :: forall a sql. (:+:) a b a -> [UntypedCol sql]
gRow = forall a. HasCallStack => String -> a
error String
"unreachable"
instance {-# OVERLAPS #-}
(TL.TypeError
( 'TL.Text "Columns are now allowed to nest other columns."
'TL.:$$:
'TL.Text "Remove any fields of type 'Col s a' from your table type."
)) => GRelation (K1 i (C.Col s a)) where
gParams :: forall a. K1 i (Col s a) a -> IO [Either Param Param]
gParams = forall a. HasCallStack => String -> a
error String
"unreachable"
gTblCols :: Proxy (K1 i (Col s a))
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols = forall a. HasCallStack => String -> a
error String
"unreachable"
gNew :: forall sql. Proxy (K1 i (Col s a)) -> [UntypedCol sql]
gNew = forall a. HasCallStack => String -> a
error String
"unreachable"
gRow :: forall a sql. K1 i (Col s a) a -> [UntypedCol sql]
gRow = forall a. HasCallStack => String -> a
error String
"unreachable"