module Database.PostgreSQL.ORM.CreateTable (
modelCreateStatement, modelCreate, GDefTypes(..)
, jtCreateStatement, jtCreate
) where
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Int
import Data.List
import Data.Monoid
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Types
import GHC.Generics
import Database.PostgreSQL.ORM.Model
import Database.PostgreSQL.ORM.Association
import Database.PostgreSQL.ORM.SqlType
class GDefTypes f where
gDefTypes :: f p -> [S.ByteString]
instance (SqlType c) => GDefTypes (K1 i c) where
gDefTypes ~(K1 c) = [sqlType c]
instance (GDefTypes a, GDefTypes b) => GDefTypes (a :*: b) where
gDefTypes ~(a :*: b) = gDefTypes a ++ gDefTypes b
instance (GDefTypes f) => GDefTypes (M1 i c f) where
gDefTypes ~(M1 fp) = gDefTypes fp
customModelCreateStatement :: forall a.
(Model a, Generic a, GDefTypes (Rep a)) =>
[(S.ByteString, S.ByteString)]
-> [S.ByteString]
-> a
-> Query
customModelCreateStatement except constraints a
| not (null extraneous) =
error $ "customCreateTableStatement: no such columns: " ++ show extraneous
| otherwise = Query $ S.concat [
"CREATE TABLE ", quoteIdent $ modelTable info, " ("
, S.intercalate ", " (go types names)
, S.concat $ concatMap (\c -> [", ", c]) constraints, ")"
]
where extraneous = fst (unzip except) \\ names
types = gDefTypes $ from a
info = modelInfo :: ModelInfo a
names = modelColumns info
go (t:ts) (n:ns)
| Just t' <- lookup n except = quoteIdent n <> " " <> t' : go ts ns
| otherwise = quoteIdent n <> " " <> t : go ts ns
go [] [] = []
go _ _ = error $ "createTable: " ++ S8.unpack (modelTable info) ++
" has incorrect number of columns"
modelCreateStatement :: forall a. (Model a, Generic a, GDefTypes (Rep a))
=> a -> Query
modelCreateStatement a = customModelCreateStatement except constraints a
where ModelCreateInfo except constraint = modelCreateInfo :: ModelCreateInfo a
constraints = if S.null constraint then [] else [constraint]
modelCreate :: (Model a, Generic a, GDefTypes (Rep a)) =>
Connection -> a -> IO Int64
modelCreate c a = execute_ c (modelCreateStatement a)
jtCreateStatement :: (Model a, Model b) => JoinTable a b -> Query
jtCreateStatement jt = Query $ S.concat [
"CREATE TABLE ", quoteIdent $ jtTable jt, " ("
, S.intercalate ", " $ sort [typa, typb]
, ", UNIQUE (", S.intercalate ", " $ sort [ida, idb], "))"
]
where ida = quoteIdent $ jtColumnA jt
idb = quoteIdent $ jtColumnB jt
refa = (undefined :: JoinTable a b -> DBRef a) jt
refb = (undefined :: JoinTable a b -> DBRef b) jt
typa = ida <> " " <> sqlBaseType refa <> " ON DELETE CASCADE NOT NULL"
typb = idb <> " " <> sqlBaseType refb <> " ON DELETE CASCADE NOT NULL"
jtCreate :: (Model a, Model b) => Connection -> JoinTable a b -> IO Int64
jtCreate c jt = execute_ c (jtCreateStatement jt)