{-# LANGUAGE
AllowAmbiguousTypes
, ConstraintKinds
, DeriveAnyClass
, DeriveGeneric
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, OverloadedStrings
, RankNTypes
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeFamilyDependencies
, TypeInType
, TypeOperators
, UndecidableInstances
, UndecidableSuperClasses
#-}
module Squeal.PostgreSQL.Schema
(
PGType (..)
, HasOid (..)
, NullityType (..)
, ColumnType
, ColumnsType
, RelationType
, NilRelation
, RelationsType
, TableType
, SchemumType (..)
, SchemaType
, (:=>)
, ColumnConstraint (..)
, TableConstraint (..)
, TableConstraints
, NilTableConstraints
, Uniquely
, (:::)
, Alias (Alias)
, renderAlias
, renderAliases
, Aliased (As)
, Aliasable (as)
, renderAliasedAs
, AliasesOf
, ZipAliased (..)
, Has
, HasUnique
, HasAll
, IsLabel (..)
, IsQualified (..)
, IsPGlabel (..)
, PGlabel (..)
, renderLabel
, renderLabels
, Grouping (..)
, GroupedBy
, Join
, With
, Create
, Drop
, Alter
, Rename
, Elem
, In
, PGNum
, PGIntegral
, PGFloating
, PGTypeOf
, SameTypes
, SamePGType
, AllNotNull
, NotAllNull
, NullifyType
, NullifyRelation
, NullifyRelations
, ColumnsToRelation
, TableToColumns
, TableToRelation
, ConstraintInvolves
, DropIfConstraintsInvolve
, PG
, EnumFrom
, LabelsFrom
, CompositeFrom
, FieldNamesFrom
, FieldTypesFrom
, ConstructorsOf
, ConstructorNameOf
, ConstructorNamesOf
, FieldsOf
, FieldNameOf
, FieldNamesOf
, FieldTypeOf
, FieldTypesOf
, RecordCodeOf
, MapMaybes (..)
, Nulls
) where
import Control.DeepSeq
import Data.Aeson (Value)
import Data.ByteString (ByteString)
import Data.Int (Int16, Int32, Int64)
import Data.Kind
import Data.Monoid hiding (All)
import Data.Scientific (Scientific)
import Data.String
import Data.Text (Text)
import Data.Time
import Data.Word (Word16, Word32, Word64)
import Data.Type.Bool
import Data.UUID.Types (UUID)
import Generics.SOP
import GHC.OverloadedLabels
import GHC.TypeLits
import Network.IP.Addr
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Text.Lazy as Lazy
import qualified GHC.Generics as GHC
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
| PGenum [Symbol]
| PGcomposite [(Symbol, 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 family Uniquely
(key :: [Symbol])
(constraints :: TableConstraints) :: Constraint where
Uniquely key (uq ::: 'Unique key ': constraints) = ()
Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()
Uniquely key (_ ': constraints) = Uniquely key constraints
type TableType = (TableConstraints,ColumnsType)
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 TableToColumns (table :: TableType) :: ColumnsType where
TableToColumns (constraints :=> columns) = columns
type family TableToRelation (table :: TableType) :: RelationType where
TableToRelation tab = ColumnsToRelation (TableToColumns tab)
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,GHC.Generic,Ord,Show,NFData)
instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
fromLabel = Alias
instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
fromLabel = fromLabel :* Nil
instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias
renderAlias :: KnownSymbol alias => Alias alias -> ByteString
renderAlias = doubleQuoted . fromString . symbolVal
renderAliases
:: All KnownSymbol aliases => NP Alias aliases -> [ByteString]
renderAliases = hcollapse
. hcmap (Proxy @KnownSymbol) (K . renderAlias)
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))
instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
=> IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
fromLabel = fromLabel @alias2 `As` fromLabel @alias1
class KnownSymbol alias => Aliasable alias expression aliased
| aliased -> expression
, aliased -> alias
where as :: expression -> Alias alias -> aliased
instance (alias ~ alias1, KnownSymbol alias) => Aliasable alias
(expression ty)
(Aliased expression (alias1 ::: ty))
where
as = As
instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
(expression ty)
(NP (Aliased expression) tys)
where
expression `as` alias = expression `As` alias :* Nil
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
class
( SListI (ZipAs ns xs)
, All KnownSymbol ns
) => ZipAliased ns xs where
type family ZipAs
(ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs
zipAs
:: NP Alias ns
-> NP expr xs
-> NP (Aliased expr) (ZipAs ns xs)
instance ZipAliased '[] '[] where
type ZipAs '[] '[] = '[]
zipAs Nil Nil = Nil
instance
( KnownSymbol n
, ZipAliased ns xs
) => ZipAliased (n ': ns) (x ': xs) where
type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs
zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs
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
( All KnownSymbol aliases
) => HasAll
(aliases :: [Symbol])
(fields :: [(Symbol,kind)])
(subfields :: [(Symbol,kind)])
| aliases fields -> subfields where
instance {-# OVERLAPPING #-} HasAll '[] fields '[]
instance {-# OVERLAPPABLE #-}
(Has alias fields field, HasAll aliases fields subfields)
=> HasAll (alias ': aliases) fields (alias ::: field ': subfields)
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)
class SamePGType
(ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
instance ty0 ~ ty1 => SamePGType
(alias0 ::: def0 :=> nullity0 ty0)
(alias1 ::: def1 :=> nullity1 ty1)
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 x (alias ::: y ': xs) = TypeError
('Text "Create: alias "
':<>: 'ShowType alias
':<>: 'Text "already in use")
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 x xs where
Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
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 MapMaybes xs where
type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs
maybes :: NP Maybe xs -> NP I (Maybes xs)
unMaybes :: NP I (Maybes xs) -> NP Maybe xs
instance MapMaybes '[] where
type Maybes '[] = '[]
maybes Nil = Nil
unMaybes Nil = Nil
instance MapMaybes xs => MapMaybes (x ': xs) where
type Maybes (x ': xs) = Maybe x ': Maybes xs
maybes (x :* xs) = I x :* maybes xs
unMaybes (I mx :* xs) = mx :* unMaybes xs
type family Nulls tys where
Nulls '[] = '[]
Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys
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)
data SchemumType
= Table TableType
| View RelationType
| Typedef PGType
type SchemaType = [(Symbol,SchemumType)]
type family With
(relations :: RelationsType)
(schema :: SchemaType)
:: SchemaType where
With '[] schema = schema
With (alias ::: rel ': rels) schema =
alias ::: 'View rel ': With rels schema
class IsPGlabel (label :: Symbol) expr where label :: expr
instance label ~ label1
=> IsPGlabel label (PGlabel label1) where label = PGlabel
instance labels ~ '[label]
=> IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil
data PGlabel (label :: Symbol) = PGlabel
renderLabel :: KnownSymbol label => proxy label -> ByteString
renderLabel (_ :: proxy label) =
"\'" <> fromString (symbolVal (Proxy @label)) <> "\'"
renderLabels
:: All KnownSymbol labels => NP PGlabel labels -> [ByteString]
renderLabels = hcollapse
. hcmap (Proxy @KnownSymbol) (K . renderLabel)
type family PG (hask :: Type) :: PGType where
PG Bool = 'PGbool
PG Int16 = 'PGint2
PG Int32 = 'PGint4
PG Int64 = 'PGint8
PG Word16 = 'PGint2
PG Word32 = 'PGint4
PG Word64 = 'PGint8
PG Scientific = 'PGnumeric
PG Float = 'PGfloat4
PG Double = 'PGfloat8
PG Char = 'PGchar 1
PG Text = 'PGtext
PG Lazy.Text = 'PGtext
PG ByteString = 'PGbytea
PG Lazy.ByteString = 'PGbytea
PG LocalTime = 'PGtimestamp
PG UTCTime = 'PGtimestamptz
PG Day = 'PGdate
PG TimeOfDay = 'PGtime
PG (TimeOfDay, TimeZone) = 'PGtimetz
PG DiffTime = 'PGinterval
PG UUID = 'PGuuid
PG (NetAddr IP) = 'PGinet
PG Value = 'PGjson
PG ty = TypeError
('Text "There is no Postgres basic type for " ':<>: 'ShowType ty)
type family EnumFrom (hask :: Type) :: PGType where
EnumFrom hask = 'PGenum (LabelsFrom hask)
type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where
LabelsFrom hask =
ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
type family CompositeFrom (hask :: Type) :: PGType where
CompositeFrom hask =
'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask))
type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where
FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))
type family FieldTypesFrom (hask :: Type) :: [PGType] where
FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask))
type family ConstructorsOf (datatype :: Type.DatatypeInfo)
:: [Type.ConstructorInfo] where
ConstructorsOf ('Type.ADT _module _datatype constructors) =
constructors
ConstructorsOf ('Type.Newtype _module _datatype constructor) =
'[constructor]
type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
:: Type.ConstructorName where
ConstructorNameOf ('Type.Constructor name) = name
ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
('Text "ConstructorNameOf error: non-nullary constructor "
':<>: 'Text name)
ConstructorNameOf ('Type.Record name _fields) = TypeError
('Text "ConstructorNameOf error: non-nullary constructor "
':<>: 'Text name)
type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
:: [Type.ConstructorName] where
ConstructorNamesOf '[] = '[]
ConstructorNamesOf (constructor ': constructors) =
ConstructorNameOf constructor ': ConstructorNamesOf constructors
type family FieldsOf (datatype :: Type.DatatypeInfo)
:: [Type.FieldInfo] where
FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =
fields
FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =
fields
type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where
FieldNameOf ('Type.FieldInfo name) = name
type family FieldNamesOf (fields :: [Type.FieldInfo])
:: [Type.FieldName] where
FieldNamesOf '[] = '[]
FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields
type family FieldTypeOf (maybe :: Type) where
FieldTypeOf (Maybe hask) = PG hask
FieldTypeOf ty = TypeError
('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)
type family FieldTypesOf (fields :: [Type]) where
FieldTypesOf '[] = '[]
FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields
type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where
RecordCodeOf _hask '[tys] = tys
RecordCodeOf hask _tys = TypeError
('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)