module Database.PostgreSQL.Store.Table (
Column (..),
ColumnType (..),
ColumnEntity (..),
Table (..),
TableEntity (..),
buildTableSchema,
insertColumns,
insertColumnsOn,
GenericTable,
describeGenericTable,
KColumns (..),
KTable (..),
GColumns (..),
GTable (..),
AnalyzeRecordRep,
AnalyzeTableRep,
AnalyzeTable
) where
import GHC.Generics
import GHC.TypeLits
import Control.Monad
import Data.Kind
import Data.Proxy
import qualified Data.ByteString as B
import Database.PostgreSQL.Store.Entity
import Database.PostgreSQL.Store.Utilities
import Database.PostgreSQL.Store.ColumnEntity
import Database.PostgreSQL.Store.Query.Builder
data KColumns
= TCombine KColumns KColumns
| TSelector Symbol Type
data Column = Column {
colName :: B.ByteString,
colType :: ColumnType
}
class GColumns (rec :: KColumns) where
gDescribeColumns :: proxy rec -> [Column]
instance (KnownSymbol name, ColumnEntity typ) => GColumns ('TSelector name typ) where
gDescribeColumns _ =
[Column (buildByteString (symbolVal (Proxy :: Proxy name)))
(describeColumnType (Proxy :: Proxy typ))]
instance (GColumns lhs, GColumns rhs) => GColumns ('TCombine lhs rhs) where
gDescribeColumns _ =
gDescribeColumns (Proxy :: Proxy lhs)
++ gDescribeColumns (Proxy :: Proxy rhs)
type family AnalyzeRecordRep org (rec :: * -> *) :: KColumns where
AnalyzeRecordRep org (S1 ('MetaSel ('Just name) m1 m2 m3) (Rec0 typ)) =
'TSelector name typ
AnalyzeRecordRep org (S1 ('MetaSel 'Nothing m1 m2 m3) a) =
TypeError ('Text "Given type "
':<>: 'ShowType org
':<>: 'Text " must have a single record constructor")
AnalyzeRecordRep org (lhs :*: rhs) =
'TCombine (AnalyzeRecordRep org lhs) (AnalyzeRecordRep org rhs)
AnalyzeRecordRep org U1 =
TypeError ('Text "Given type "
':<>: 'ShowType org
':<>: 'Text " has one constructor, therefore that constructor must have \
\at least one field")
AnalyzeRecordRep org other =
TypeError ('Text "Given type "
':<>: 'ShowType org
':<>: 'Text " has a constructor with an invalid selector"
':$$: 'ShowType other)
data KTable = TTable Symbol KColumns
data Table = Table {
tableName :: B.ByteString,
tableCols :: [Column]
}
class GTable (tbl :: KTable) where
gDescribeTable :: proxy tbl -> Table
instance (KnownSymbol name, GColumns cols) => GTable ('TTable name cols) where
gDescribeTable _ =
Table (buildByteString (symbolVal (Proxy :: Proxy name)))
(gDescribeColumns (Proxy :: Proxy cols))
type family AnalyzeTableRep org (dat :: * -> *) :: KTable where
AnalyzeTableRep org (D1 meta1 (C1 ('MetaCons name f 'True) sel)) =
'TTable name (AnalyzeRecordRep org sel)
AnalyzeTableRep org (D1 meta other) =
TypeError ('Text "Given type "
':<>: 'ShowType org
':<>: 'Text " must have a single record constructor")
AnalyzeTableRep org other =
TypeError ('Text "Given type "
':<>: 'ShowType org
':<>: 'Text " is not a valid data type"
':$$: 'ShowType other)
type AnalyzeTable a = AnalyzeTableRep a (Rep a)
type GenericTable a = (Generic a, GTable (AnalyzeTable a))
describeGenericTable :: (GenericTable a) => proxy a -> Table
describeGenericTable proxy =
gDescribeTable ((const Proxy :: proxy a -> Proxy (AnalyzeTable a)) proxy)
class (Entity a) => TableEntity a where
describeTableType :: proxy a -> Table
default describeTableType :: (GenericTable a) => proxy a -> Table
describeTableType = describeGenericTable
buildColumn :: Column -> QueryBuilder
buildColumn (Column name (ColumnType typeName notNull mbCheck)) = do
insertName name
insertCode " "
insertName typeName
when notNull (insertCode " NOT NULL")
case mbCheck of
Just gen -> do
insertCode " CHECK("
gen name
insertCode ")"
Nothing -> pure ()
buildTableSchema :: Table -> QueryBuilder
buildTableSchema (Table name cols) = do
insertCode "CREATE TABLE IF NOT EXISTS "
insertName name
insertCode "("
insertCommaSeperated (map buildColumn cols)
insertCode ")"
insertColumns :: Table -> QueryBuilder
insertColumns (Table name cols) =
insertCommaSeperated (map insertColumn cols)
where
insertColumn (Column colName _) = do
insertName name
insertCode "."
insertName colName
insertColumnsOn :: Table -> B.ByteString -> QueryBuilder
insertColumnsOn (Table _ cols) name =
insertCommaSeperated (map insertColumn cols)
where
insertColumn (Column colName _) = do
insertName name
insertCode "."
insertName colName