{-# LANGUAGE
AllowAmbiguousTypes
, ConstraintKinds
, DataKinds
, DeriveAnyClass
, DeriveDataTypeable
, DeriveGeneric
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, MagicHash
, MultiParamTypeClasses
, OverloadedStrings
, PolyKinds
, RankNTypes
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeFamilies
, TypeInType
, TypeOperators
, UndecidableInstances
#-}
module Squeal.PostgreSQL.Schema
(
PGType (..)
, HasOid (..)
, NullityType (..)
, ColumnType
, ColumnsType
, RelationType
, NilRelation
, RelationsType
, TableType
, TablesType
, NilTables
, Grouping (..)
, GroupedBy
, (:=>)
, ColumnConstraint (..)
, TableConstraint (..)
, TableConstraints
, NilTableConstraints
, (:::)
, Alias (Alias)
, renderAlias
, Aliased (As)
, renderAliasedAs
, AliasesOf
, Has
, HasUnique
, IsLabel (..)
, IsQualified (..)
, Join
, Create
, Drop
, Alter
, Rename
, Elem
, In
, PGNum
, PGIntegral
, PGFloating
, PGTypeOf
, SameTypes
, AllNotNull
, NotAllNull
, NullifyType
, NullifyRelation
, NullifyRelations
, ColumnsToRelation
, RelationToColumns
, TableToColumns
, TablesToRelations
, RelationsToTables
, ConstraintInvolves
, DropIfConstraintsInvolve
, SameField
, SameFields
) where
import Control.DeepSeq
import Data.ByteString
import Data.Monoid
import Data.String
import Data.Word
import Data.Type.Bool
import Generics.SOP (AllZip)
import GHC.Generics (Generic)
import GHC.Exts
import GHC.OverloadedLabels
import GHC.TypeLits
import qualified Generics.SOP.Type.Metadata as Type
import Squeal.PostgreSQL.Render
data PGType
= PGbool
| PGint2
| PGint4
| PGint8
| PGnumeric
| PGfloat4
| PGfloat8
| PGchar Nat
| PGvarchar Nat
| PGtext
| PGbytea
| PGtimestamp
| PGtimestamptz
| PGdate
| PGtime
| PGtimetz
| PGinterval
| PGuuid
| PGinet
| PGjson
| PGjsonb
| PGvararray PGType
| PGfixarray Nat PGType
| UnsafePGType Symbol
class HasOid (ty :: PGType) where oid :: Word32
instance HasOid 'PGbool where oid = 16
instance HasOid 'PGint2 where oid = 21
instance HasOid 'PGint4 where oid = 23
instance HasOid 'PGint8 where oid = 20
instance HasOid 'PGnumeric where oid = 1700
instance HasOid 'PGfloat4 where oid = 700
instance HasOid 'PGfloat8 where oid = 701
instance HasOid ('PGchar n) where oid = 18
instance HasOid ('PGvarchar n) where oid = 1043
instance HasOid 'PGtext where oid = 25
instance HasOid 'PGbytea where oid = 17
instance HasOid 'PGtimestamp where oid = 1114
instance HasOid 'PGtimestamptz where oid = 1184
instance HasOid 'PGdate where oid = 1082
instance HasOid 'PGtime where oid = 1083
instance HasOid 'PGtimetz where oid = 1266
instance HasOid 'PGinterval where oid = 1186
instance HasOid 'PGuuid where oid = 2950
instance HasOid 'PGinet where oid = 869
instance HasOid 'PGjson where oid = 114
instance HasOid 'PGjsonb where oid = 3802
data NullityType
= Null PGType
| NotNull PGType
type (:=>) constraint ty = '(constraint,ty)
infixr 7 :=>
type (:::) (alias :: Symbol) ty = '(alias,ty)
infixr 6 :::
data ColumnConstraint
= Def
| NoDef
type ColumnType = (ColumnConstraint,NullityType)
type ColumnsType = [(Symbol,ColumnType)]
data TableConstraint
= Check [Symbol]
| Unique [Symbol]
| PrimaryKey [Symbol]
| ForeignKey [Symbol] Symbol [Symbol]
type TableConstraints = [(Symbol,TableConstraint)]
type family NilTableConstraints :: TableConstraints where
NilTableConstraints = '[]
type TableType = (TableConstraints,ColumnsType)
type TablesType = [(Symbol,TableType)]
type family NilTables :: TablesType where NilTables = '[]
type RelationType = [(Symbol,NullityType)]
type family NilRelation :: RelationType where NilRelation = '[]
type RelationsType = [(Symbol,RelationType)]
type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
ColumnsToRelation '[] = '[]
ColumnsToRelation (column ::: constraint :=> ty ': columns) =
column ::: ty ': ColumnsToRelation columns
type family RelationToColumns (relation :: RelationType) :: ColumnsType where
RelationToColumns '[] = '[]
RelationToColumns (column ::: ty ': columns) =
column ::: 'NoDef :=> ty ': RelationToColumns columns
type family TableToColumns (table :: TableType) :: ColumnsType where
TableToColumns (constraints :=> columns) = columns
type family TablesToRelations (tables :: TablesType) :: RelationsType where
TablesToRelations '[] = '[]
TablesToRelations (alias ::: constraint :=> columns ': tables) =
alias ::: ColumnsToRelation columns ': TablesToRelations tables
type family RelationsToTables (tables :: RelationsType) :: TablesType where
RelationsToTables '[] = '[]
RelationsToTables (alias ::: columns ': relations) =
alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations
data Grouping
= Ungrouped
| Grouped [(Symbol,Symbol)]
class (KnownSymbol relation, KnownSymbol column)
=> GroupedBy relation column bys where
instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)
=> GroupedBy relation column ('(table,column) ': bys)
instance {-# OVERLAPPABLE #-}
( KnownSymbol relation
, KnownSymbol column
, GroupedBy relation column bys
) => GroupedBy relation column (tabcol ': bys)
data Alias (alias :: Symbol) = Alias
deriving (Eq,Generic,Ord,Show,NFData)
instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
fromLabel = Alias
renderAlias :: KnownSymbol alias => Alias alias -> ByteString
renderAlias = doubleQuoted . fromString . symbolVal
data Aliased expression aliased where
As
:: KnownSymbol alias
=> expression ty
-> Alias alias
-> Aliased expression (alias ::: ty)
deriving instance Show (expression ty)
=> Show (Aliased expression (alias ::: ty))
deriving instance Eq (expression ty)
=> Eq (Aliased expression (alias ::: ty))
deriving instance Ord (expression ty)
=> Ord (Aliased expression (alias ::: ty))
renderAliasedAs
:: (forall ty. expression ty -> ByteString)
-> Aliased expression aliased
-> ByteString
renderAliasedAs render (expression `As` alias) =
render expression <> " AS " <> renderAlias alias
type family AliasesOf aliaseds where
AliasesOf '[] = '[]
AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
type HasUnique alias fields field = fields ~ '[alias ::: field]
class KnownSymbol alias =>
Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
| alias fields -> field where
instance {-# OVERLAPPING #-} KnownSymbol alias
=> Has alias (alias ::: field ': fields) field
instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
=> Has alias (field' ': fields) field
class IsQualified table column expression where
(!) :: Alias table -> Alias column -> expression
infixl 9 !
instance IsQualified table column (Alias table, Alias column) where (!) = (,)
type family Elem x xs where
Elem x '[] = 'False
Elem x (x ': xs) = 'True
Elem x (_ ': xs) = Elem x xs
type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
type PGNum ty =
In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
type family PGTypeOf (ty :: NullityType) :: PGType where
PGTypeOf (nullity pg) = pg
type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
:: Constraint where
SameTypes '[] '[] = ()
SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
= (ty0 ~ ty1, SameTypes columns0 columns1)
type family AllNotNull (columns :: ColumnsType) :: Constraint where
AllNotNull '[] = ()
AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
type family NotAllNull (columns :: ColumnsType) :: Constraint where
NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
type family NullifyType (ty :: NullityType) :: NullityType where
NullifyType ('Null ty) = 'Null ty
NullifyType ('NotNull ty) = 'Null ty
type family NullifyRelation (columns :: RelationType) :: RelationType where
NullifyRelation '[] = '[]
NullifyRelation (column ::: ty ': columns) =
column ::: NullifyType ty ': NullifyRelation columns
type family NullifyRelations (tables :: RelationsType) :: RelationsType where
NullifyRelations '[] = '[]
NullifyRelations (table ::: columns ': tables) =
table ::: NullifyRelation columns ': NullifyRelations tables
type family Join xs ys where
Join '[] ys = ys
Join (x ': xs) ys = x ': Join xs ys
type family Create alias x xs where
Create alias x '[] = '[alias ::: x]
Create alias y (x ': xs) = x ': Create alias y xs
type family Drop alias xs where
Drop alias ((alias ::: x) ': xs) = xs
Drop alias (x ': xs) = x ': Drop alias xs
type family Alter alias xs x where
Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
type family Rename alias0 alias1 xs where
Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
class SameField
(fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where
instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
type family SameFields
(datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)
:: Constraint where
SameFields
('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
columns
= AllZip SameField fields columns
SameFields
('Type.Newtype _module _datatype ('Type.Record _constructor fields))
columns
= AllZip SameField fields columns
type family ConstraintInvolves column constraint where
ConstraintInvolves column ('Check columns) = column `Elem` columns
ConstraintInvolves column ('Unique columns) = column `Elem` columns
ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns
ConstraintInvolves column ('ForeignKey columns tab refcolumns)
= column `Elem` columns
type family DropIfConstraintsInvolve column constraints where
DropIfConstraintsInvolve column '[] = '[]
DropIfConstraintsInvolve column (alias ::: constraint ': constraints)
= If (ConstraintInvolves column constraint)
(DropIfConstraintsInvolve column constraints)
(alias ::: constraint ': DropIfConstraintsInvolve column constraints)