{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
{-# LANGUAGE
AllowAmbiguousTypes
, ConstraintKinds
, DeriveAnyClass
, DeriveGeneric
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, LambdaCase
, OverloadedStrings
, RankNTypes
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeFamilyDependencies
, TypeInType
, TypeOperators
, UndecidableInstances
, UndecidableSuperClasses
#-}
module Squeal.PostgreSQL.Schema
(
PGType (..)
, NullityType (..)
, RowType
, FromType
, PG
, NullPG
, TuplePG
, RowPG
, Json (..)
, Jsonb (..)
, Composite (..)
, Enumerated (..)
, ColumnType
, ColumnsType
, TableType
, SchemumType (..)
, SchemaType
, (:=>)
, ColumnConstraint (..)
, TableConstraint (..)
, TableConstraints
, Uniquely
, (:::)
, Alias (Alias)
, renderAlias
, renderAliases
, Aliased (As)
, Aliasable (as)
, renderAliasedAs
, Has
, HasUnique
, HasAll
, IsLabel (..)
, IsQualified (..)
, renderAliasString
, IsPGlabel (..)
, PGlabel (..)
, renderLabel
, renderLabels
, LabelsPG
, Grouping (..)
, GroupedBy
, AlignedList (..)
, single
, Create
, Drop
, Alter
, Rename
, DropIfConstraintsInvolve
, Join
, Elem
, In
, Length
, HasOid (..)
, PGNum
, PGIntegral
, PGFloating
, PGTypeOf
, PGArrayOf
, PGArray
, PGTextArray
, PGJsonType
, PGJsonKey
, SamePGType
, AllNotNull
, NotAllNull
, NullifyType
, NullifyRow
, NullifyFrom
, TableToColumns
, TableToRow
) where
import Control.Category
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 Data.Vector (Vector)
import Generics.SOP
import Generics.SOP.Record
import GHC.OverloadedLabels
import GHC.TypeLits
import Network.IP.Addr
import Prelude hiding (id, (.))
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 NullityType
| PGfixarray Nat NullityType
| PGenum [Symbol]
| PGcomposite RowType
| 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 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 RowType = [(Symbol,NullityType)]
type FromType = [(Symbol,RowType)]
type family ColumnsToRow (columns :: ColumnsType) :: RowType where
ColumnsToRow '[] = '[]
ColumnsToRow (column ::: constraint :=> ty ': columns) =
column ::: ty ': ColumnsToRow columns
type family TableToColumns (table :: TableType) :: ColumnsType where
TableToColumns (constraints :=> columns) = columns
type family TableToRow (table :: TableType) :: RowType where
TableToRow tab = ColumnsToRow (TableToColumns tab)
data Grouping
= Ungrouped
| Grouped [(Symbol,Symbol)]
class (KnownSymbol table, KnownSymbol column)
=> GroupedBy table column bys where
instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
=> GroupedBy table column ('(table,column) ': bys)
instance {-# OVERLAPPABLE #-}
( KnownSymbol table
, KnownSymbol column
, GroupedBy table column bys
) => GroupedBy table 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
renderAliasString :: KnownSymbol alias => Alias alias -> ByteString
renderAliasString = singleQuotedText . 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 (KnownSymbol alias, alias ~ alias1) => 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 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 =
'[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"
type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty
type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t
type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t
type family PGArray name arr :: Constraint where
PGArray name ('PGvararray x) = ()
PGArray name ('PGfixarray n x) = ()
PGArray name val = TypeError
('Text name :<>: 'Text ": Unsatisfied PGArray constraint. Expected either: "
:$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)
:$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)
:$$: 'Text "But got: " :<>: 'ShowType val)
type family PGArrayOf name arr ty :: Constraint where
PGArrayOf name ('PGvararray x) ty = x ~ ty
PGArrayOf name ('PGfixarray n x) ty = x ~ ty
PGArrayOf name val ty = TypeError
( 'Text name :<>: 'Text "Unsatisfied PGArrayOf constraint. Expected either: "
:$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )
:$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )
:$$: 'Text "But got: " :<>: 'ShowType val)
type PGTextArray name arr = PGArrayOf name arr ('NotNull 'PGtext)
type family PGTypeOf (ty :: NullityType) :: PGType where
PGTypeOf (nullity pg) = pg
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 NullifyRow (columns :: RowType) :: RowType where
NullifyRow '[] = '[]
NullifyRow (column ::: ty ': columns) =
column ::: NullifyType ty ': NullifyRow columns
type family NullifyFrom (tables :: FromType) :: FromType where
NullifyFrom '[] = '[]
NullifyFrom (table ::: columns ': tables) =
table ::: NullifyRow columns ': NullifyFrom 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
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)
type family Length (xs :: [k]) :: Nat where
Length (x : xs) = 1 + Length xs
Length '[] = 0
data SchemumType
= Table TableType
| View RowType
| Typedef PGType
type SchemaType = [(Symbol,SchemumType)]
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) =
"\'" <> renderSymbol @label <> "\'"
renderLabels
:: All KnownSymbol labels => NP PGlabel labels -> [ByteString]
renderLabels = hcollapse
. hcmap (Proxy @KnownSymbol) (K . renderLabel)
type family PG (hask :: Type) :: PGType
type instance PG Bool = 'PGbool
type instance PG Int16 = 'PGint2
type instance PG Int32 = 'PGint4
type instance PG Int64 = 'PGint8
type instance PG Word16 = 'PGint2
type instance PG Word32 = 'PGint4
type instance PG Word64 = 'PGint8
type instance PG Scientific = 'PGnumeric
type instance PG Float = 'PGfloat4
type instance PG Double = 'PGfloat8
type instance PG Char = 'PGchar 1
type instance PG Text = 'PGtext
type instance PG Lazy.Text = 'PGtext
type instance PG String = 'PGtext
type instance PG ByteString = 'PGbytea
type instance PG Lazy.ByteString = 'PGbytea
type instance PG LocalTime = 'PGtimestamp
type instance PG UTCTime = 'PGtimestamptz
type instance PG Day = 'PGdate
type instance PG TimeOfDay = 'PGtime
type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
type instance PG DiffTime = 'PGinterval
type instance PG UUID = 'PGuuid
type instance PG (NetAddr IP) = 'PGinet
type instance PG Value = 'PGjson
type instance PG (Json hask) = 'PGjson
type instance PG (Jsonb hask) = 'PGjsonb
type instance PG (Vector hask) = 'PGvararray (NullPG hask)
type instance PG (hask, hask) = 'PGfixarray 2 (NullPG hask)
type instance PG (hask, hask, hask) = 'PGfixarray 3 (NullPG hask)
type instance PG (hask, hask, hask, hask) = 'PGfixarray 4 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask) = 'PGfixarray 5 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask, hask)
= 'PGfixarray 6 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask, hask, hask)
= 'PGfixarray 7 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask, hask, hask, hask)
= 'PGfixarray 8 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask)
= 'PGfixarray 9 (NullPG hask)
type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask, hask)
= 'PGfixarray 10 (NullPG hask)
type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
newtype Json hask = Json {getJson :: hask}
deriving (Eq, Ord, Show, Read, GHC.Generic)
newtype Jsonb hask = Jsonb {getJsonb :: hask}
deriving (Eq, Ord, Show, Read, GHC.Generic)
newtype Composite record = Composite {getComposite :: record}
deriving (Eq, Ord, Show, Read, GHC.Generic)
newtype Enumerated enum = Enumerated {getEnumerated :: enum}
deriving (Eq, Ord, Show, Read, GHC.Generic)
type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
LabelsPG hask =
ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
type family RowPG (hask :: Type) :: RowType where
RowPG hask = RowOf (RecordCodeOf hask)
type family RowOf (fields :: [(Symbol, Type)]) :: RowType where
RowOf '[] = '[]
RowOf (field ': fields) = FieldPG field ': RowOf fields
type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where
FieldPG (field ::: hask) = field ::: NullPG hask
type family NullPG (hask :: Type) :: NullityType where
NullPG (Maybe hask) = 'Null (PG hask)
NullPG hask = 'NotNull (PG hask)
type family TuplePG (hask :: Type) :: [NullityType] where
TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))
type family TupleOf (tuple :: [Type]) :: [NullityType] where
TupleOf '[] = '[]
TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
TupleCodeOf hask '[tuple] = tuple
TupleCodeOf hask '[] =
TypeError
( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
:$$: 'Text "It is a void type with no constructors."
)
TupleCodeOf hask (_ ': _ ': _) =
TypeError
( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."
:$$: 'Text "It is a sum type with more than one constructor."
)
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 PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
type PGJsonType = '[ 'PGjson, 'PGjsonb ]
data AlignedList p x0 x1 where
Done :: AlignedList p x x
(:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
infixr 7 :>>
instance Category (AlignedList p) where
id = Done
(.) list = \case
Done -> list
step :>> steps -> step :>> (steps >>> list)
single :: p x0 x1 -> AlignedList p x0 x1
single step = step :>> Done