{-| Module: Squeal.PostgreSQL.Schema Description: Embedding of PostgreSQL type and alias system Copyright: (c) Eitan Chatav, 2017 Maintainer: eitan@morphism.tech Stability: experimental A type-level DSL for kinds of PostgreSQL types, constraints, and aliases. -} {-# 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 ( -- * Types PGType (..) , HasOid (..) , NullityType (..) , ColumnType , ColumnsType , RelationType , NilRelation , RelationsType , TableType , TablesType , NilTables -- * Grouping , Grouping (..) , GroupedBy -- * Constraints , (:=>) , ColumnConstraint (..) , TableConstraint (..) , TableConstraints , NilTableConstraints -- * Aliases , (:::) , Alias (Alias) , renderAlias , Aliased (As) , renderAliasedAs , AliasesOf , Has , HasUnique , IsLabel (..) , IsQualified (..) -- * Type Families , Join , Create , Drop , Alter , Rename , Elem , In , PGNum , PGIntegral , PGFloating , PGTypeOf , SameTypes , AllNotNull , NotAllNull , NullifyType , NullifyRelation , NullifyRelations , ColumnsToRelation , RelationToColumns , TableToColumns , TablesToRelations , RelationsToTables , ConstraintInvolves , DropIfConstraintsInvolve -- * Generics , 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 -- | `PGType` is the promoted datakind of PostgreSQL types. -- -- >>> import Squeal.PostgreSQL.Schema -- >>> :kind 'PGbool -- 'PGbool :: PGType data PGType = PGbool -- ^ logical Boolean (true/false) | PGint2 -- ^ signed two-byte integer | PGint4 -- ^ signed four-byte integer | PGint8 -- ^ signed eight-byte integer | PGnumeric -- ^ arbitrary precision numeric type | PGfloat4 -- ^ single precision floating-point number (4 bytes) | PGfloat8 -- ^ double precision floating-point number (8 bytes) | PGchar Nat -- ^ fixed-length character string | PGvarchar Nat -- ^ variable-length character string | PGtext -- ^ variable-length character string | PGbytea -- ^ binary data ("byte array") | PGtimestamp -- ^ date and time (no time zone) | PGtimestamptz -- ^ date and time, including time zone | PGdate -- ^ calendar date (year, month, day) | PGtime -- ^ time of day (no time zone) | PGtimetz -- ^ time of day, including time zone | PGinterval -- ^ time span | PGuuid -- ^ universally unique identifier | PGinet -- ^ IPv4 or IPv6 host address | PGjson -- ^ textual JSON data | PGjsonb -- ^ binary JSON data, decomposed | PGvararray PGType -- ^ variable length array | PGfixarray Nat PGType -- ^ fixed length array | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types -- | The object identifier of a `PGType`. -- -- >>> :set -XTypeApplications -- >>> oid @'PGbool -- 16 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 -- | `NullityType` encodes the potential presence or definite absence of a -- @NULL@ allowing operations which are sensitive to such to be well typed. -- -- >>> :kind 'Null 'PGint4 -- 'Null 'PGint4 :: NullityType -- >>> :kind 'NotNull ('PGvarchar 50) -- 'NotNull ('PGvarchar 50) :: NullityType data NullityType = Null PGType -- ^ @NULL@ may be present | NotNull PGType -- ^ @NULL@ is absent -- | The constraint operator, `:=>` is a type level pair -- between a "constraint" and some type, for use in pairing -- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType` -- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`. type (:=>) constraint ty = '(constraint,ty) infixr 7 :=> -- | The alias operator `:::` is like a promoted version of `As`, -- a type level pair between -- an alias and some type, like a column alias and either a `ColumnType` or -- `NullityType` or a table alias and either a `TableType` or a `RelationType` -- or a constraint alias and a `TableConstraint`. type (:::) (alias :: Symbol) ty = '(alias,ty) infixr 6 ::: -- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates. -- A column can be assigned a default value. -- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also -- request explicitly that a column be set to its default value, -- without having to know what that value is. data ColumnConstraint = Def -- ^ @DEFAULT@ is available for inserts and updates | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates -- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the -- base `PGType` for a column. -- -- >>> :set -XTypeFamilies -XTypeInType -- >>> import GHC.TypeLits -- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4 -- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext type ColumnType = (ColumnConstraint,NullityType) -- | `ColumnsType` is a row of `ColumnType`s. -- -- >>> :{ -- type family UsersColumns :: ColumnsType where -- UsersColumns = -- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext -- , "id" ::: 'Def :=> 'NotNull 'PGint4 -- ] -- :} type ColumnsType = [(Symbol,ColumnType)] -- | `TableConstraint` encodes various forms of data constraints -- of columns in a table. -- `TableConstraint`s give you as much control over the data in your tables -- as you wish. If a user attempts to store data in a column that would -- violate a constraint, an error is raised. This applies -- even if the value came from the default value definition. data TableConstraint = Check [Symbol] | Unique [Symbol] | PrimaryKey [Symbol] | ForeignKey [Symbol] Symbol [Symbol] -- | A `TableConstraints` is a row of `TableConstraint`s. type TableConstraints = [(Symbol,TableConstraint)] -- | A monokinded empty `TableConstraints`. type family NilTableConstraints :: TableConstraints where NilTableConstraints = '[] -- | `TableType` encodes a row of constraints on a table as well as the types -- of its columns. -- -- >>> :{ -- type family UsersTable :: TableType where -- UsersTable = -- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> -- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 -- , "name" ::: 'NoDef :=> 'NotNull 'PGtext -- ] -- :} type TableType = (TableConstraints,ColumnsType) -- | `TablesType` is a row of `TableType`s, thought of as a union. -- -- >>> :{ -- type family Schema :: TablesType where -- Schema = -- '[ "users" ::: -- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> -- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 -- , "name" ::: 'NoDef :=> 'NotNull 'PGtext -- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2) -- ] -- , "emails" ::: -- '[ "pk_emails" ::: 'PrimaryKey '["id"] -- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] -- ] :=> -- '[ "id" ::: 'Def :=> 'NotNull 'PGint4 -- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 -- , "email" ::: 'NoDef :=> 'Null 'PGtext -- ] -- ] -- :} type TablesType = [(Symbol,TableType)] -- | A monokinded empty `TablesType`. type family NilTables :: TablesType where NilTables = '[] -- | `RelationType` is a row of `NullityType` -- -- >>> :{ -- type family PersonRelation :: RelationType where -- PersonRelation = -- '[ "name" ::: 'NotNull 'PGtext -- , "age" ::: 'NotNull 'PGint4 -- , "dateOfBirth" ::: 'Null 'PGdate -- ] -- :} type RelationType = [(Symbol,NullityType)] -- | A monokinded empty `RelationType`. type family NilRelation :: RelationType where NilRelation = '[] -- | `RelationsType` is a row of `RelationType`s, thought of as a product. type RelationsType = [(Symbol,RelationType)] -- | `ColumnsToRelation` removes column constraints. type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where ColumnsToRelation '[] = '[] ColumnsToRelation (column ::: constraint :=> ty ': columns) = column ::: ty ': ColumnsToRelation columns -- | `RelationToColumns` adds `'NoDef` column constraints. type family RelationToColumns (relation :: RelationType) :: ColumnsType where RelationToColumns '[] = '[] RelationToColumns (column ::: ty ': columns) = column ::: 'NoDef :=> ty ': RelationToColumns columns -- | `TableToColumns` removes table constraints. type family TableToColumns (table :: TableType) :: ColumnsType where TableToColumns (constraints :=> columns) = columns -- | `TablesToRelations` removes both table and column constraints. type family TablesToRelations (tables :: TablesType) :: RelationsType where TablesToRelations '[] = '[] TablesToRelations (alias ::: constraint :=> columns ': tables) = alias ::: ColumnsToRelation columns ': TablesToRelations tables -- | `RelationsToTables` adds both trivial table and column constraints. type family RelationsToTables (tables :: RelationsType) :: TablesType where RelationsToTables '[] = '[] RelationsToTables (alias ::: columns ': relations) = alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations -- | `Grouping` is an auxiliary namespace, created by -- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used -- for typesafe aggregation data Grouping = Ungrouped -- ^ no aggregation permitted | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped {- | A `GroupedBy` constraint indicates that a table qualified column is a member of the auxiliary namespace created by @GROUP BY@ clauses and thus, may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating. -} 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) -- | `Alias`es are proxies for a type level string or `Symbol` -- and have an `IsLabel` instance so that with @-XOverloadedLabels@ -- -- >>> :set -XOverloadedLabels -- >>> #foobar :: Alias "foobar" -- Alias data Alias (alias :: Symbol) = Alias deriving (Eq,Generic,Ord,Show,NFData) instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where fromLabel = Alias -- | >>> renderAlias #jimbob -- "jimbob" renderAlias :: KnownSymbol alias => Alias alias -> ByteString renderAlias = fromString . symbolVal -- | The `As` operator is used to name an expression. `As` is like a demoted -- version of `:::`. -- -- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String) -- As (Just "hello") Alias 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)) -- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just") -- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int) -- "Just AS an_int" renderAliasedAs :: (forall ty. expression ty -> ByteString) -> Aliased expression aliased -> ByteString renderAliasedAs render (expression `As` alias) = render expression <> " AS " <> renderAlias alias -- | `AliasesOf` retains the AliasesOf in a row. type family AliasesOf aliaseds where AliasesOf '[] = '[] AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys -- | @HasUnique alias fields field@ is a constraint that proves that -- @fields@ is a singleton of @alias ::: field@. type HasUnique alias fields field = fields ~ '[alias ::: field] -- | @Has alias fields field@ is a constraint that proves that -- @fields@ has a field of @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 -- | Analagous to `IsLabel`, the constraint -- `IsQualified` defines `!` for a column alias qualified -- by a table alias. class IsQualified table column expression where (!) :: Alias table -> Alias column -> expression infixl 9 ! instance IsQualified table column (Alias table, Alias column) where (!) = (,) -- | @Elem@ is a promoted `Data.List.elem`. type family Elem x xs where Elem x '[] = 'False Elem x (x ': xs) = 'True Elem x (_ ': xs) = Elem x xs -- | @In x xs@ is a constraint that proves that @x@ is in @xs@. type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True -- | `PGNum` is a constraint on `PGType` whose -- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint. type PGNum ty = In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8] -- | `PGFloating` is a constraint on `PGType` whose -- `Squeal.PostgreSQL.Expression.Expression`s -- have `Fractional` and `Floating` constraints. type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric] -- | `PGIntegral` is a constraint on `PGType` whose -- `Squeal.PostgreSQL.Expression.Expression`s -- have `Squeal.PostgreSQL.Expression.div_` and -- `Squeal.PostgreSQL.Expression.mod_` functions. type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8] -- | `PGTypeOf` forgets about @NULL@ and any column constraints. type family PGTypeOf (ty :: NullityType) :: PGType where PGTypeOf (nullity pg) = pg -- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same -- length and the same `ColumnType`s. type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType) :: Constraint where SameTypes '[] '[] = () SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1) = (ty0 ~ ty1, SameTypes columns0 columns1) -- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s. type family AllNotNull (columns :: ColumnsType) :: Constraint where AllNotNull '[] = () AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns -- | `NotAllNull` is a constraint that proves a `ColumnsType` has some -- @NOT NULL@. type family NotAllNull (columns :: ColumnsType) :: Constraint where NotAllNull (column ::: def :=> 'NotNull ty ': columns) = () NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns -- | `NullifyType` is an idempotent that nullifies a `ColumnType`. type family NullifyType (ty :: NullityType) :: NullityType where NullifyType ('Null ty) = 'Null ty NullifyType ('NotNull ty) = 'Null ty -- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`. type family NullifyRelation (columns :: RelationType) :: RelationType where NullifyRelation '[] = '[] NullifyRelation (column ::: ty ': columns) = column ::: NullifyType ty ': NullifyRelation columns -- | `NullifyRelations` is an idempotent that nullifies a `RelationsType` -- used to nullify the left or right hand side of an outer join -- in a `Squeal.PostgreSQL.Query.FromClause`. type family NullifyRelations (tables :: RelationsType) :: RelationsType where NullifyRelations '[] = '[] NullifyRelations (table ::: columns ': tables) = table ::: NullifyRelation columns ': NullifyRelations tables -- | `Join` is simply promoted `++` and is used in @JOIN@s in -- `Squeal.PostgreSQL.Query.FromClause`s. type family Join xs ys where Join '[] ys = ys Join (x ': xs) ys = x ': Join xs ys -- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in -- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@ -- `Squeal.PostgreSQL.Definition.addColumn`. type family Create alias x xs where Create alias x '[] = '[alias ::: x] Create alias y (x ': xs) = x ': Create alias y xs -- | @Drop alias xs@ removes the type associated with @alias@ in @xs@ -- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements -- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements. type family Drop alias xs where Drop alias ((alias ::: x) ': xs) = xs Drop alias (x ': xs) = x ': Drop alias xs -- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@ -- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable` -- and `Squeal.PostgreSQL.Definition.alterColumn`. 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 AddConstraint constraint ty where -- AddConstraint constraint (constraints :=> ty) -- = AsSet (constraint ': constraints) :=> ty -- type family DeleteFromList (e :: elem) (list :: [elem]) where -- DeleteFromList elem '[] = '[] -- DeleteFromList elem (x ': xs) = -- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs) -- type family DropConstraint constraint ty where -- DropConstraint constraint (constraints :=> ty) -- = (AsSet (DeleteFromList constraint constraints)) :=> ty -- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@ -- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and -- `Squeal.PostgreSQL.Definition.renameColumn`. 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 -- | A `SameField` constraint is an equality constraint on a -- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair. class SameField (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty) -- | A `SameFields` constraint proves that a -- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same -- field names as the column AliasesOf of a `ColumnsType`. 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 -- | Check if a `TableConstraint` involves a column 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 -- | Drop all `TableConstraint`s that involve a column 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)