module Database.PostgreSQL.Store.Table (
Reference (..),
Table (..),
mkCreateQuery,
TableConstraint (..),
mkTable
) where
import Control.Monad
import Control.Monad.Except
import Data.Int
import Data.List hiding (insert)
import Data.Proxy
import Data.String
import qualified Data.ByteString as B
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Database.PostgreSQL.Store.Query
import Database.PostgreSQL.Store.Columns
import Database.PostgreSQL.Store.Result
import Database.PostgreSQL.Store.Errand
newtype Reference a = Reference { referenceID :: Int64 }
deriving (Eq, Ord)
instance Show (Reference a) where
show (Reference n) = show n
instance (QueryTable a) => Column (Reference a) where
pack ref = pack (referenceID ref)
unpack val = Reference <$> unpack val
columnTypeName proxy =
"BIGINT REFERENCES " ++ quoteIdentifier (tableName tableProxy) ++
" (" ++ quoteIdentifier (tableIDName tableProxy) ++ ")"
where
tableProxy = (const Proxy :: Proxy (Reference a) -> Proxy a) proxy
columnAllowNull _ = False
instance Result (Reference a) where
queryResultProcessor = Reference <$> unpackColumn
class Table a where
insert :: a -> Errand (Reference a)
insertMany :: [a] -> Errand [Reference a]
insertMany = mapM insert
find :: Reference a -> Errand a
update :: Reference a -> a -> Errand ()
delete :: Reference a -> Errand ()
createTableQuery :: Proxy a -> Query
data TableField = TableField String Type Name
data TableDec = TableDec Name Name [TableField] Pat
tableIdentifier :: Name -> String
tableIdentifier name = quoteIdentifier (show name)
tableFieldIdentifiers :: [TableField] -> String
tableFieldIdentifiers fields =
intercalate ", " (map (\ (TableField name _ _) -> quoteIdentifier name) fields)
tableInsertStatementBegin :: TableDec -> String
tableInsertStatementBegin (TableDec table _ fields _) =
"INSERT INTO " ++
tableIdentifier table ++
" (" ++
tableFieldIdentifiers fields ++
") VALUES "
tableInsertStatementEnd :: String
tableInsertStatementEnd =
" RETURNING \"$id\""
callConstructor :: Name -> [Name] -> Exp
callConstructor ctor params =
foldl AppE (ConE ctor) (map VarE params)
makeQuerySelectors :: [TableField] -> Q Exp
makeQuerySelectors fields =
ListE <$> mapM (\ (TableField field _ _) -> [e| SelectorField $(stringE field) |]) fields
makeResultProcessor :: TableDec -> Q Exp
makeResultProcessor (TableDec _ ctor fields _) = do
bindingNames <- mapM (\ (TableField name _ _) -> newName name) fields
pure (DoE (map makeBinding bindingNames ++
[makeConstruction bindingNames]))
where
makeBinding name =
BindS (VarP name) (VarE 'unpackColumn)
makeConstruction names =
NoBindS (AppE (VarE 'pure) (callConstructor ctor names))
makeCreateQuery :: TableDec -> [TableConstraint] -> Q Exp
makeCreateQuery (TableDec table _ fields _) constraints =
runQueryBuilder $ do
writeStringCode "CREATE TABLE IF NOT EXISTS " :: QueryBuilder [Q Exp] (Q Exp)
writeIdentifier (show table)
writeStringCode " ("
intercalateBuilder (writeStringCode ", ") $
identDescription :
map describeField fields ++
map describeConstraint constraints
writeStringCode ")"
where
identDescription = do
writeIdentifier "$id"
writeStringCode "BIGSERIAL NOT NULL PRIMARY KEY"
describeField :: TableField -> QueryBuilder [Q Exp] (Q Exp)
describeField (TableField name typ _) =
writeCode [e| fromString (columnDescription (Proxy :: Proxy $(pure typ))
$(stringE (quoteIdentifier name))) |]
describeConstraint :: TableConstraint -> QueryBuilder [Q Exp] (Q Exp)
describeConstraint (Unique names) = do
writeStringCode "UNIQUE ("
intercalateBuilder (writeStringCode ", ") $
map (writeIdentifier . nameBase) names
writeStringCode ")"
describeConstraint (Check code) = do
writeStringCode "CHECK ("
writeStringCode code
writeStringCode ")"
makeInsertQuery :: TableDec -> Q Exp
makeInsertQuery (TableDec table _ fields _) =
runQueryBuilder $ do
writeCode "INSERT INTO " :: QueryBuilder String (Q Exp)
writeIdentifier (show table)
writeCode " ("
intercalateBuilder (writeCode ", ") $
map (\ (TableField name _ _) -> writeIdentifier name) fields
writeCode ") VALUES ("
intercalateBuilder (writeCode ", ") $
map (\ (TableField _ _ boundName) -> writeParam [e| pack $(varE boundName) |]) fields
writeCode ") RETURNING "
writeIdentifier "$id"
makeInsertManyQuery :: Name -> TableDec -> Q Exp
makeInsertManyQuery rows dec@(TableDec _ _ fields destructPat) =
[e|
let
writeTuple $(pure destructPat) = do
writeStringCode "(" :: QueryBuilder B.ByteString Value
intercalateBuilder (writeStringCode ",") $(ListE <$> mapM packColumn fields)
writeStringCode ")"
in runQueryBuilder $ do
writeStringCode $(stringE (tableInsertStatementBegin dec))
intercalateBuilder (writeStringCode ",") (map writeTuple $(varE rows))
writeStringCode $(stringE tableInsertStatementEnd)
|]
where
packColumn (TableField _ _ boundName) = [e| writeColumn $(varE boundName) |]
makeFindQuery :: Name -> TableDec -> Q Exp
makeFindQuery ref (TableDec table _ fields _) =
runQueryBuilder $ do
writeCode "SELECT " :: QueryBuilder String (Q Exp)
intercalateBuilder (writeCode ", ") $
map (\ (TableField name _ _) -> writeIdentifier name) fields
writeCode " FROM "
writeIdentifier (show table)
writeCode " WHERE "
writeIdentifier "$id"
writeCode " = "
writeParam [e| pack $(varE ref) |]
makeUpdateQuery :: Name -> TableDec -> Q Exp
makeUpdateQuery ref (TableDec table _ fields _) =
runQueryBuilder $ do
writeCode "UPDATE " :: QueryBuilder String (Q Exp)
writeIdentifier (show table)
writeCode " SET "
intercalateBuilder (writeCode ", ") $
flip map fields $ \ (TableField name _ boundName) -> do
writeIdentifier name
writeCode " = "
writeParam [e| pack $(varE boundName) |]
writeCode " WHERE "
writeIdentifier "$id"
writeCode " = "
writeParam [e| pack $(varE ref) |]
makeDeleteQuery :: Name -> Name -> Q Exp
makeDeleteQuery ref table =
runQueryBuilder $ do
writeCode "DELETE FROM " :: QueryBuilder String (Q Exp)
writeIdentifier (show table)
writeCode " WHERE "
writeIdentifier "$id"
writeCode " = "
writeParam [e| pack $(varE ref) |]
implementClasses :: TableDec -> [TableConstraint] -> Q [Dec]
implementClasses dec@(TableDec table _ fields destructPat) constraints =
[d|
instance QueryTable $(conT table) where
tableName _ = $(stringE (show table))
tableIDName _ = "$id"
tableSelectors _ = $(makeQuerySelectors fields)
instance Result $(conT table) where
queryResultProcessor = $(makeResultProcessor dec)
instance Table $(conT table) where
insert $(pure destructPat) = do
rs <- query $(makeInsertQuery dec)
case rs of
(ref : _) -> pure ref
_ -> throwError EmptyResult
insertMany [] = pure []
insertMany rows =
query $(makeInsertManyQuery 'rows dec)
find ref = do
rs <- query $(makeFindQuery 'ref dec)
case rs of
(row : _) -> pure row
_ -> throwError EmptyResult
update ref $(pure destructPat) =
query_ $(makeUpdateQuery 'ref dec)
delete ref =
query_ $(makeDeleteQuery 'ref table)
createTableQuery _ =
$(makeCreateQuery dec constraints)
|]
checkRecordFields :: [VarBangType] -> Q [TableField]
checkRecordFields fields =
forM fields $ \ (name, _, typ) -> do
ii <- isInstance ''Column [typ]
unless ii $
fail ("Type of field '" ++ show name ++ "' ('" ++ show typ ++
"') type does not implement '" ++ show ''Column ++ "'")
TableField (nameBase name) typ <$> newName (nameBase name)
checkNormalFields :: [BangType] -> Q [TableField]
checkNormalFields fields = do
forM (fields `zip` [1 .. length fields]) $ \ ((_, typ), idx) -> do
ii <- isInstance ''Column [typ]
unless ii $
fail ("Type of constructor parameter #" ++ show idx ++ " ('" ++ show typ ++
"') type does not implement '" ++ show ''Column ++ "'")
TableField ("column" ++ show idx) typ <$> newName ("column" ++ show idx)
makeCtorPattern :: Name -> [TableField] -> Pat
makeCtorPattern ctor fields =
ConP ctor (map (\ (TableField _ _ name) -> VarP name) fields)
checkTableCtor :: Name -> Con -> Q TableDec
checkTableCtor table (RecC ctor ctorFields) = do
when (length ctorFields < 1)
(fail ("'" ++ show ctor ++ "' must have at least one field"))
fields <- checkRecordFields ctorFields
pure (TableDec table ctor fields (makeCtorPattern ctor fields))
checkTableCtor table (NormalC ctor ctorFields) = do
when (length ctorFields < 1)
(fail ("'" ++ show ctor ++ "' must have at least one field"))
fields <- checkNormalFields ctorFields
pure (TableDec table ctor fields (makeCtorPattern ctor fields))
checkTableCtor table _ =
fail ("'" ++ show table ++ "' must have a normal or record constructor")
checkTableDec :: Name -> Dec -> Q TableDec
checkTableDec _ (DataD ctx tableName typeVars kind ctorNames _) = do
when (length ctx > 0)
(fail ("'" ++ show tableName ++ "' must not have a context"))
when (length typeVars > 0)
(fail ("'" ++ show tableName ++ "' must not use type variables"))
when (length ctorNames /= 1)
(fail ("'" ++ show tableName ++ "' must have 1 constructor"))
when (kind /= Nothing && kind /= Just StarT)
(fail ("'" ++ show tableName ++ "' must have kind *"))
let [ctorName] = ctorNames
checkTableCtor tableName ctorName
checkTableDec tableName _ =
fail ("'" ++ show tableName ++ "' must declare a data type")
data TableConstraint
= Unique [Name]
| Check String
deriving (Show, Eq, Ord)
mkTable :: Name -> [TableConstraint] -> Q [Dec]
mkTable name constraints = do
info <- reify name
case info of
TyConI dec -> do
tableDec <- checkTableDec name dec
implementClasses tableDec constraints
_ -> fail ("'" ++ show name ++ "' is not a type constructor")
isType :: Name -> Q Bool
isType name = do
info <- reify name
pure $ case info of
TyConI _ -> True
_ -> False
mkCreateQuery :: Name -> Q Exp
mkCreateQuery name = do
it <- isType name
unless it (fail "Given name does not refer to a type.")
[e| createTableQuery (Proxy :: Proxy $(pure (ConT name))) |]