{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}
{-# LANGUAGE GADTs, CPP, DeriveGeneric, DataKinds #-}
module Database.Selda.Generic
( Relational, Generic
, tblCols, mkDummy, identify, params, def, gNew
) where
import Control.Monad.State
import Data.Dynamic
import Data.Text as Text (Text, pack)
#if MIN_VERSION_base(4, 10, 0)
import Data.Typeable
#endif
import GHC.Generics hiding (R, (:*:), Selector)
import qualified GHC.Generics as G ((:*:)(..), Selector)
#if MIN_VERSION_base(4, 9, 0)
import qualified GHC.TypeLits as TL
import qualified GHC.Generics as G ((:+:)(..))
#endif
import Unsafe.Coerce
import Control.Exception (Exception (..), try, throw)
import System.IO.Unsafe
import Database.Selda.Types
import Database.Selda.Selectors
import Database.Selda.SqlType
import Database.Selda.SqlRow (SqlRow)
import Database.Selda.Table.Type
import Database.Selda.SQL (Param (..))
import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..))
import qualified Database.Selda.Column as C (Col)
#if !MIN_VERSION_base(4, 11, 0)
import Data.Monoid
#endif
type Relational a =
( Generic a
, SqlRow a
, GRelation (Rep a)
, GSelectors a (Rep a)
)
newtype Dummy a = Dummy a
mkDummy :: (Generic a, GRelation (Rep a)) => Dummy a
mkDummy = Dummy $ to $ evalState gMkDummy 0
identify :: Dummy a -> (a -> b) -> Int
identify (Dummy d) f = unsafeCoerce $ f d
params :: Relational a => a -> [Either Param Param]
params = unsafePerformIO . gParams . from
tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols _ fieldMod =
evalState (gTblCols (Proxy :: Proxy (Rep a)) Nothing rename) 0
where
rename n Nothing = mkColName $ fieldMod ("col_" <> pack (show n))
rename _ (Just name) = modColName name fieldMod
data DefaultValueException = DefaultValueException
deriving Show
instance Exception DefaultValueException
def :: SqlType a => a
def = throw DefaultValueException
class GRelation f where
gParams :: f a -> IO [Either Param Param]
gTblCols :: Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gMkDummy :: State Int (f a)
gNew :: Proxy f -> [UntypedCol sql]
instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where
gParams (M1 x) = gParams x
gTblCols _ = gTblCols (Proxy :: Proxy a)
gMkDummy = M1 <$> gMkDummy
gNew _ = gNew (Proxy :: Proxy a)
instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) =>
GRelation (M1 S c a) where
gParams (M1 x) = gParams x
gTblCols _ _ = gTblCols (Proxy :: Proxy a) name
where
name =
case selName ((M1 undefined) :: M1 S c a b) of
"" -> Nothing
s -> Just (mkColName $ pack s)
gMkDummy = M1 <$> gMkDummy
gNew _ = gNew (Proxy :: Proxy a)
instance (Typeable a, SqlType a) => GRelation (K1 i a) where
gParams (K1 x) = do
res <- try $ return $! x
return $ case res of
Right x' -> [Right $ Param (mkLit x')]
Left DefaultValueException -> [Left $ Param (defaultValue :: Lit a)]
gTblCols _ name rename = do
n <- get
put (n+1)
let name' = rename n name
return
[ ColInfo
{ colName = name'
, colType = sqlType (Proxy :: Proxy a)
, colAttrs = optReq
, colFKs = []
, colExpr = Untyped (Col name')
}
]
where
maybeTyCon = typeRepTyCon (typeRep (Proxy :: Proxy (Maybe ())))
optReq
| typeRepTyCon (typeRep (Proxy :: Proxy a)) == maybeTyCon = [Optional]
| otherwise = [Required]
gMkDummy = do
n <- get
put (n+1)
return $ unsafeCoerce n
gNew _ = [Untyped (Lit (defaultValue :: Lit a))]
instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where
gParams (a G.:*: b) = liftM2 (++) (gParams a) (gParams b)
gTblCols _ _ rename = do
as <- gTblCols a Nothing rename
bs <- gTblCols b Nothing rename
return (as ++ bs)
where
a = Proxy :: Proxy a
b = Proxy :: Proxy b
gMkDummy = do
a <- gMkDummy :: State Int (a x)
b <- gMkDummy :: State Int (b x)
return (a G.:*: b)
gNew _ = gNew (Proxy :: Proxy a) ++ gNew (Proxy :: Proxy b)
#if MIN_VERSION_base(4, 9, 0)
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 = error "unreachable"
gTblCols = error "unreachable"
gMkDummy = error "unreachable"
gNew = error "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 = error "unreachable"
gTblCols = error "unreachable"
gMkDummy = error "unreachable"
gNew = error "unreachable"
#endif