{-# 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, 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 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)
)
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]
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)
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)
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]
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
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"
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"
gNew = error "unreachable"
#endif