mirror of
https://github.com/ilyakooo0/squeal.git
synced 2024-09-11 13:57:29 +03:00
Merge pull request #149 from morphismtech/dev-if-not-exists
"create if not exists" and "create or replace"
This commit is contained in:
Eitan Chatav
GitHub
commit
64d641a96a
@ -138,11 +138,11 @@ type Expr x
|
||||
. Expression outer commons grp schemas params from x
|
||||
```
|
||||
|
||||
There is also a function type `(:-->)`, which is a subtype of the usual Haskell function
|
||||
There is also a function type `(-->)`, which is a subtype of the usual Haskell function
|
||||
type `(->)`.
|
||||
|
||||
```Haskell
|
||||
type (:-->) x y
|
||||
type (-->) x y
|
||||
= forall outer commons grp schemas params from
|
||||
. Expression outer commons grp schemas params from x
|
||||
-> Expression outer commons grp schemas params from y
|
||||
|
||||
@ -25,6 +25,14 @@ library
|
||||
Squeal.PostgreSQL.Alias
|
||||
Squeal.PostgreSQL.Binary
|
||||
Squeal.PostgreSQL.Definition
|
||||
Squeal.PostgreSQL.Definition.Function
|
||||
Squeal.PostgreSQL.Definition.Index
|
||||
Squeal.PostgreSQL.Definition.Table
|
||||
Squeal.PostgreSQL.Definition.Table.Column
|
||||
Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
Squeal.PostgreSQL.Definition.Type
|
||||
Squeal.PostgreSQL.Definition.Schema
|
||||
Squeal.PostgreSQL.Definition.View
|
||||
Squeal.PostgreSQL.Expression
|
||||
Squeal.PostgreSQL.Expression.Aggregate
|
||||
Squeal.PostgreSQL.Expression.Collection
|
||||
@ -36,7 +44,7 @@ library
|
||||
Squeal.PostgreSQL.Expression.Null
|
||||
Squeal.PostgreSQL.Expression.Parameter
|
||||
Squeal.PostgreSQL.Expression.Range
|
||||
Squeal.PostgreSQL.Expression.SetOf
|
||||
Squeal.PostgreSQL.Expression.Set
|
||||
Squeal.PostgreSQL.Expression.Sort
|
||||
Squeal.PostgreSQL.Expression.Subquery
|
||||
Squeal.PostgreSQL.Expression.Text
|
||||
|
||||
@ -195,6 +195,14 @@ module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
|
||||
import Squeal.PostgreSQL.Alias as X
|
||||
import Squeal.PostgreSQL.Binary as X
|
||||
import Squeal.PostgreSQL.Definition as X
|
||||
import Squeal.PostgreSQL.Definition.Function as X
|
||||
import Squeal.PostgreSQL.Definition.Index as X
|
||||
import Squeal.PostgreSQL.Definition.Schema as X
|
||||
import Squeal.PostgreSQL.Definition.Table as X
|
||||
import Squeal.PostgreSQL.Definition.Table.Column as X
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint as X
|
||||
import Squeal.PostgreSQL.Definition.Type as X
|
||||
import Squeal.PostgreSQL.Definition.View as X
|
||||
import Squeal.PostgreSQL.Expression as X
|
||||
import Squeal.PostgreSQL.Expression.Aggregate as X
|
||||
import Squeal.PostgreSQL.Expression.Collection as X
|
||||
@ -206,7 +214,7 @@ import Squeal.PostgreSQL.Expression.Math as X
|
||||
import Squeal.PostgreSQL.Expression.Null as X
|
||||
import Squeal.PostgreSQL.Expression.Parameter as X
|
||||
import Squeal.PostgreSQL.Expression.Range as X
|
||||
import Squeal.PostgreSQL.Expression.SetOf as X
|
||||
import Squeal.PostgreSQL.Expression.Set as X
|
||||
import Squeal.PostgreSQL.Expression.Sort as X
|
||||
import Squeal.PostgreSQL.Expression.Subquery as X
|
||||
import Squeal.PostgreSQL.Expression.Text as X
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
238
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs
Normal file
238
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs
Normal file
@ -0,0 +1,238 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Function
|
||||
Description: Create and drop function and operator definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create and drop function and operator definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Function
|
||||
( createFunction
|
||||
, createOrReplaceFunction
|
||||
, createSetFunction
|
||||
, createOrReplaceSetFunction
|
||||
, createBinaryOp
|
||||
, createLeftOp
|
||||
, createRightOp
|
||||
, dropFunction
|
||||
, dropFunctionIfExists
|
||||
, dropOperator
|
||||
, dropOperatorIfExists
|
||||
, FunctionDefinition(..)
|
||||
, languageSqlExpr
|
||||
, languageSqlQuery
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
import GHC.TypeLits
|
||||
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Query
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
createFunction
|
||||
:: ( Has sch schemas schema
|
||||
, KnownSymbol fun
|
||||
, SOP.SListI args )
|
||||
=> QualifiedAlias sch fun
|
||||
-> NP (TypeExpression schemas) args
|
||||
-> TypeExpression schemas ret
|
||||
-> FunctionDefinition schemas args ('Returns ret)
|
||||
-> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
|
||||
createFunction fun args ret fundef = UnsafeDefinition $
|
||||
"CREATE" <+> "FUNCTION" <+> renderSQL fun
|
||||
<+> parenthesized (renderCommaSeparated renderSQL args)
|
||||
<+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
|
||||
|
||||
createOrReplaceFunction
|
||||
:: ( Has sch schemas schema
|
||||
, KnownSymbol fun
|
||||
, SOP.SListI args )
|
||||
=> QualifiedAlias sch fun
|
||||
-> NP (TypeExpression schemas) args
|
||||
-> TypeExpression schemas ret
|
||||
-> FunctionDefinition schemas args ('Returns ret)
|
||||
-> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
|
||||
createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
|
||||
"CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
|
||||
<+> parenthesized (renderCommaSeparated renderSQL args)
|
||||
<+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
|
||||
|
||||
languageSqlExpr
|
||||
:: Expression '[] '[] 'Ungrouped schemas args '[] ret
|
||||
-> FunctionDefinition schemas args ('Returns ret)
|
||||
languageSqlExpr expr = UnsafeFunctionDefinition $
|
||||
"language sql as"
|
||||
<+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
|
||||
|
||||
languageSqlQuery
|
||||
:: Query '[] '[] schemas args rets
|
||||
-> FunctionDefinition schemas args ('ReturnsTable rets)
|
||||
languageSqlQuery qry = UnsafeFunctionDefinition $
|
||||
"language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
|
||||
|
||||
createSetFunction
|
||||
:: ( Has sch schemas schema
|
||||
, KnownSymbol fun
|
||||
, SOP.SListI args
|
||||
, SOP.SListI rets )
|
||||
=> QualifiedAlias sch fun
|
||||
-> NP (TypeExpression schemas) args
|
||||
-> NP (Aliased (TypeExpression schemas)) rets
|
||||
-> FunctionDefinition schemas args ('ReturnsTable rets)
|
||||
-> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
|
||||
createSetFunction fun args rets fundef = UnsafeDefinition $
|
||||
"CREATE" <+> "FUNCTION" <+> renderSQL fun
|
||||
<+> parenthesized (renderCommaSeparated renderSQL args)
|
||||
<+> "RETURNS" <+> "TABLE"
|
||||
<+> parenthesized (renderCommaSeparated renderRet rets)
|
||||
<+> renderSQL fundef <> ";"
|
||||
where
|
||||
renderRet :: Aliased (TypeExpression s) r -> ByteString
|
||||
renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
|
||||
|
||||
createOrReplaceSetFunction
|
||||
:: ( Has sch schemas schema
|
||||
, KnownSymbol fun
|
||||
, SOP.SListI args
|
||||
, SOP.SListI rets )
|
||||
=> QualifiedAlias sch fun
|
||||
-> NP (TypeExpression schemas) args
|
||||
-> NP (Aliased (TypeExpression schemas)) rets
|
||||
-> FunctionDefinition schemas args ('ReturnsTable rets)
|
||||
-> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
|
||||
createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
|
||||
"CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
|
||||
<+> parenthesized (renderCommaSeparated renderSQL args)
|
||||
<+> "RETURNS" <+> "TABLE"
|
||||
<+> parenthesized (renderCommaSeparated renderRet rets)
|
||||
<+> renderSQL fundef <> ";"
|
||||
where
|
||||
renderRet :: Aliased (TypeExpression s) r -> ByteString
|
||||
renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
|
||||
|
||||
createBinaryOp
|
||||
:: forall op fun sch schemas schema x y z.
|
||||
( Has sch schemas schema
|
||||
, Has fun schema ('Function ('[x,y] :=> 'Returns z))
|
||||
, KnownSymbol op )
|
||||
=> QualifiedAlias sch fun
|
||||
-> TypeExpression schemas x
|
||||
-> TypeExpression schemas y
|
||||
-> Definition schemas
|
||||
(Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
|
||||
createBinaryOp fun x y = UnsafeDefinition $
|
||||
"CREATE" <+> "OPERATOR" <+> renderSymbol @op
|
||||
<+> parenthesized (commaSeparated opdef)
|
||||
where
|
||||
opdef =
|
||||
[ "FUNCTION" <+> "=" <+> renderSQL fun
|
||||
, "LEFTARG" <+> "=" <+> renderSQL x
|
||||
, "RIGHTARG" <+> "=" <+> renderSQL y ]
|
||||
|
||||
createLeftOp
|
||||
:: forall op fun sch schemas schema x y.
|
||||
( Has sch schemas schema
|
||||
, Has fun schema ('Function ('[x] :=> 'Returns y))
|
||||
, KnownSymbol op )
|
||||
=> QualifiedAlias sch fun
|
||||
-> TypeExpression schemas x
|
||||
-> Definition schemas
|
||||
(Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
|
||||
createLeftOp fun x = UnsafeDefinition $
|
||||
"CREATE" <+> "OPERATOR" <+> renderSymbol @op
|
||||
<+> parenthesized (commaSeparated opdef)
|
||||
where
|
||||
opdef =
|
||||
[ "FUNCTION" <+> "=" <+> renderSQL fun
|
||||
, "RIGHTARG" <+> "=" <+> renderSQL x ]
|
||||
|
||||
createRightOp
|
||||
:: forall op fun sch schemas schema x y.
|
||||
( Has sch schemas schema
|
||||
, Has fun schema ('Function ('[x] :=> 'Returns y))
|
||||
, KnownSymbol op )
|
||||
=> QualifiedAlias sch fun
|
||||
-> TypeExpression schemas x
|
||||
-> Definition schemas
|
||||
(Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
|
||||
createRightOp fun x = UnsafeDefinition $
|
||||
"CREATE" <+> "OPERATOR" <+> renderSymbol @op
|
||||
<+> parenthesized (commaSeparated opdef)
|
||||
where
|
||||
opdef =
|
||||
[ "FUNCTION" <+> "=" <+> renderSQL fun
|
||||
, "LEFTARG" <+> "=" <+> renderSQL x ]
|
||||
|
||||
dropFunction
|
||||
:: (Has sch schemas schema, KnownSymbol fun)
|
||||
=> QualifiedAlias sch fun
|
||||
-- ^ name of the user defined function
|
||||
-> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
|
||||
dropFunction fun = UnsafeDefinition $
|
||||
"DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
|
||||
|
||||
dropFunctionIfExists
|
||||
:: (Has sch schemas schema, KnownSymbol fun)
|
||||
=> QualifiedAlias sch fun
|
||||
-- ^ name of the user defined function
|
||||
-> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
|
||||
dropFunctionIfExists fun = UnsafeDefinition $
|
||||
"DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
|
||||
|
||||
dropOperator
|
||||
:: (Has sch schemas schema, KnownSymbol op)
|
||||
=> QualifiedAlias sch op
|
||||
-- ^ name of the user defined operator
|
||||
-> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
|
||||
dropOperator op = UnsafeDefinition $
|
||||
"DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
|
||||
|
||||
dropOperatorIfExists
|
||||
:: (Has sch schemas schema, KnownSymbol op)
|
||||
=> QualifiedAlias sch op
|
||||
-- ^ name of the user defined operator
|
||||
-> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
|
||||
dropOperatorIfExists op = UnsafeDefinition $
|
||||
"DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
|
||||
|
||||
newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
|
||||
{ renderFunctionDefinition :: ByteString }
|
||||
deriving (Eq,Show,GHC.Generic,NFData)
|
||||
instance RenderSQL (FunctionDefinition schemas args ret) where
|
||||
renderSQL = renderFunctionDefinition
|
||||
159
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs
Normal file
159
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs
Normal file
@ -0,0 +1,159 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Index
|
||||
Description: Create and drop index definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create and drop index definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Index
|
||||
( createIndex
|
||||
, createIndexIfNotExists
|
||||
, dropIndex
|
||||
, dropIndexIfExists
|
||||
, IndexMethod (..)
|
||||
, btree
|
||||
, hash
|
||||
, gist
|
||||
, spgist
|
||||
, gin
|
||||
, brin
|
||||
) where
|
||||
|
||||
import Data.ByteString
|
||||
import GHC.TypeLits
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Expression.Sort
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
{- |
|
||||
>>> :{
|
||||
type Table = '[] :=>
|
||||
'[ "a" ::: 'NoDef :=> 'Null 'PGint4
|
||||
, "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
|
||||
setup =
|
||||
createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
|
||||
createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
|
||||
CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
|
||||
-}
|
||||
createIndex
|
||||
:: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
|
||||
=> Alias ix
|
||||
-> QualifiedAlias sch tab
|
||||
-> IndexMethod method
|
||||
-> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
|
||||
-> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
|
||||
createIndex ix tab method cols = UnsafeDefinition $
|
||||
"CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
|
||||
<+> "USING" <+> renderSQL method
|
||||
<+> parenthesized (commaSeparated (renderIndex <$> cols))
|
||||
<> ";"
|
||||
where
|
||||
renderIndex = \case
|
||||
Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
|
||||
Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
|
||||
AscNullsFirst expression -> parenthesized (renderSQL expression)
|
||||
<+> "ASC NULLS FIRST"
|
||||
DescNullsFirst expression -> parenthesized (renderSQL expression)
|
||||
<+> "DESC NULLS FIRST"
|
||||
AscNullsLast expression -> parenthesized (renderSQL expression)
|
||||
<+> "ASC NULLS LAST"
|
||||
DescNullsLast expression -> parenthesized (renderSQL expression)
|
||||
<+> "DESC NULLS LAST"
|
||||
|
||||
createIndexIfNotExists
|
||||
:: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
|
||||
=> Alias ix
|
||||
-> QualifiedAlias sch tab
|
||||
-> IndexMethod method
|
||||
-> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
|
||||
-> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
|
||||
createIndexIfNotExists ix tab method cols = UnsafeDefinition $
|
||||
"CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
|
||||
<+> "USING" <+> renderSQL method
|
||||
<+> parenthesized (commaSeparated (renderIndex <$> cols))
|
||||
<> ";"
|
||||
where
|
||||
renderIndex = \case
|
||||
Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
|
||||
Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
|
||||
AscNullsFirst expression -> parenthesized (renderSQL expression)
|
||||
<+> "ASC NULLS FIRST"
|
||||
DescNullsFirst expression -> parenthesized (renderSQL expression)
|
||||
<+> "DESC NULLS FIRST"
|
||||
AscNullsLast expression -> parenthesized (renderSQL expression)
|
||||
<+> "ASC NULLS LAST"
|
||||
DescNullsLast expression -> parenthesized (renderSQL expression)
|
||||
<+> "DESC NULLS LAST"
|
||||
|
||||
newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
|
||||
deriving stock (Eq, Ord, Show, GHC.Generic)
|
||||
instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
|
||||
btree :: IndexMethod 'Btree
|
||||
btree = UnsafeIndexMethod "btree"
|
||||
hash :: IndexMethod 'Hash
|
||||
hash = UnsafeIndexMethod "hash"
|
||||
gist :: IndexMethod 'Gist
|
||||
gist = UnsafeIndexMethod "gist"
|
||||
spgist :: IndexMethod 'Spgist
|
||||
spgist = UnsafeIndexMethod "spgist"
|
||||
gin :: IndexMethod 'Gin
|
||||
gin = UnsafeIndexMethod "gin"
|
||||
brin :: IndexMethod 'Brin
|
||||
brin = UnsafeIndexMethod "brin"
|
||||
|
||||
-- |
|
||||
-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
|
||||
-- DROP INDEX "ix";
|
||||
dropIndex
|
||||
:: (Has sch schemas schema, KnownSymbol ix)
|
||||
=> QualifiedAlias sch ix
|
||||
-- ^ name of the user defined index
|
||||
-> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
|
||||
dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
|
||||
|
||||
dropIndexIfExists
|
||||
:: (Has sch schemas schema, KnownSymbol ix)
|
||||
=> QualifiedAlias sch ix
|
||||
-- ^ name of the user defined index
|
||||
-> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
|
||||
dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
|
||||
96
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs
Normal file
96
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs
Normal file
@ -0,0 +1,96 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Schema
|
||||
Description: Create and drop schema definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create and drop schema definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Schema
|
||||
( createSchema
|
||||
, createSchemaIfNotExists
|
||||
, dropSchema
|
||||
, dropSchemaIfExists
|
||||
) where
|
||||
|
||||
import GHC.TypeLits
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
{- |
|
||||
`createSchema` enters a new schema into the current database.
|
||||
The schema name must be distinct from the name of any existing schema
|
||||
in the current database.
|
||||
|
||||
A schema is essentially a namespace: it contains named objects
|
||||
(tables, data types, functions, and operators) whose names
|
||||
can duplicate those of other objects existing in other schemas.
|
||||
Named objects are accessed by `QualifiedAlias`es with the schema
|
||||
name as a prefix.
|
||||
-}
|
||||
createSchema
|
||||
:: KnownSymbol sch
|
||||
=> Alias sch
|
||||
-> Definition schemas (Create sch '[] schemas)
|
||||
createSchema sch = UnsafeDefinition $
|
||||
"CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
|
||||
|
||||
{- | Idempotent version of `createSchema`. -}
|
||||
createSchemaIfNotExists
|
||||
:: (KnownSymbol sch, Has sch schemas schema)
|
||||
=> Alias sch
|
||||
-> Definition schemas (CreateIfNotExists sch '[] schemas)
|
||||
createSchemaIfNotExists sch = UnsafeDefinition $
|
||||
"CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
|
||||
<+> renderSQL sch <> ";"
|
||||
|
||||
-- | >>> :{
|
||||
-- let
|
||||
-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
|
||||
-- definition = dropSchema #muh_schema
|
||||
-- :}
|
||||
--
|
||||
-- >>> printSQL definition
|
||||
-- DROP SCHEMA "muh_schema";
|
||||
dropSchema
|
||||
:: KnownSymbol sch
|
||||
=> Alias sch
|
||||
-- ^ user defined schema
|
||||
-> Definition schemas (Drop sch schemas)
|
||||
dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
|
||||
|
||||
dropSchemaIfExists
|
||||
:: KnownSymbol sch
|
||||
=> Alias sch
|
||||
-- ^ user defined schema
|
||||
-> Definition schemas (DropIfExists sch schemas)
|
||||
dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
|
||||
477
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs
Normal file
477
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs
Normal file
@ -0,0 +1,477 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Table
|
||||
Description: Create, drop and alter table definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create, drop and alter table definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Table
|
||||
( createTable
|
||||
, createTableIfNotExists
|
||||
, dropTable
|
||||
, dropTableIfExists
|
||||
, alterTable
|
||||
, alterTableRename
|
||||
, AlterTable (..)
|
||||
, addConstraint
|
||||
, dropConstraint
|
||||
, AddColumn (..)
|
||||
, dropColumn
|
||||
, renameColumn
|
||||
, alterColumn
|
||||
, AlterColumn (..)
|
||||
, setDefault
|
||||
, dropDefault
|
||||
, setNotNull
|
||||
, dropNotNull
|
||||
, alterType
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
import GHC.TypeLits
|
||||
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Definition.Table.Column
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
{- | `createTable` adds a table to the schema.
|
||||
|
||||
>>> :set -XOverloadedLabels
|
||||
>>> :{
|
||||
type Table = '[] :=>
|
||||
'[ "a" ::: 'NoDef :=> 'Null 'PGint4
|
||||
, "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
|
||||
setup = createTable #tab
|
||||
(nullable int `as` #a :* nullable real `as` #b) Nil
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
|
||||
-}
|
||||
createTable
|
||||
:: ( KnownSymbol sch
|
||||
, KnownSymbol tab
|
||||
, columns ~ (col ': cols)
|
||||
, SOP.SListI columns
|
||||
, SOP.SListI constraints
|
||||
, Has sch schemas0 schema0
|
||||
, schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
|
||||
=> QualifiedAlias sch tab -- ^ the name of the table to add
|
||||
-> NP (Aliased (ColumnTypeExpression schemas0)) columns
|
||||
-- ^ the names and datatype of each column
|
||||
-> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
|
||||
-- ^ constraints that must hold for the table
|
||||
-> Definition schemas0 schemas1
|
||||
createTable tab columns constraints = UnsafeDefinition $
|
||||
"CREATE TABLE" <+> renderCreation tab columns constraints
|
||||
|
||||
{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
|
||||
Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
|
||||
`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
|
||||
the `Category` of `Definition`s.
|
||||
|
||||
>>> :set -XOverloadedLabels -XTypeApplications
|
||||
>>> :{
|
||||
type Table = '[] :=>
|
||||
'[ "a" ::: 'NoDef :=> 'Null 'PGint4
|
||||
, "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
|
||||
:}
|
||||
|
||||
>>> type Schemas = Public '["tab" ::: 'Table Table]
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition Schemas Schemas
|
||||
setup = createTableIfNotExists #tab
|
||||
(nullable int `as` #a :* nullable real `as` #b) Nil
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
|
||||
-}
|
||||
createTableIfNotExists
|
||||
:: ( KnownSymbol sch
|
||||
, KnownSymbol tab
|
||||
, columns ~ (col ': cols)
|
||||
, SOP.SListI columns
|
||||
, SOP.SListI constraints
|
||||
, Has sch schemas0 schema0
|
||||
, schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
|
||||
=> QualifiedAlias sch tab -- ^ the name of the table to add
|
||||
-> NP (Aliased (ColumnTypeExpression schemas0)) columns
|
||||
-- ^ the names and datatype of each column
|
||||
-> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
|
||||
-- ^ constraints that must hold for the table
|
||||
-> Definition schemas0 schemas1
|
||||
createTableIfNotExists tab columns constraints = UnsafeDefinition $
|
||||
"CREATE TABLE IF NOT EXISTS"
|
||||
<+> renderCreation tab columns constraints
|
||||
|
||||
-- helper function for `createTable` and `createTableIfNotExists`
|
||||
renderCreation
|
||||
:: ( KnownSymbol sch
|
||||
, KnownSymbol tab
|
||||
, SOP.SListI columns
|
||||
, SOP.SListI constraints )
|
||||
=> QualifiedAlias sch tab -- ^ the name of the table to add
|
||||
-> NP (Aliased (ColumnTypeExpression schemas0)) columns
|
||||
-- ^ the names and datatype of each column
|
||||
-> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
|
||||
-- ^ constraints that must hold for the table
|
||||
-> ByteString
|
||||
renderCreation tab columns constraints = renderSQL tab
|
||||
<+> parenthesized
|
||||
( renderCommaSeparated renderColumnDef columns
|
||||
<> ( case constraints of
|
||||
Nil -> ""
|
||||
_ -> ", " <>
|
||||
renderCommaSeparated renderConstraint constraints ) )
|
||||
<> ";"
|
||||
where
|
||||
renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
|
||||
renderColumnDef (ty `As` column) =
|
||||
renderSQL column <+> renderColumnTypeExpression ty
|
||||
renderConstraint
|
||||
:: Aliased (TableConstraintExpression sch tab schemas) constraint
|
||||
-> ByteString
|
||||
renderConstraint (constraint `As` alias) =
|
||||
"CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
|
||||
|
||||
-- | `dropTable` removes a table from the schema.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
|
||||
-- definition = dropTable #muh_table
|
||||
-- :}
|
||||
--
|
||||
-- >>> printSQL definition
|
||||
-- DROP TABLE "muh_table";
|
||||
dropTable
|
||||
:: ( Has sch schemas schema
|
||||
, KnownSymbol tab )
|
||||
=> QualifiedAlias sch tab -- ^ table to remove
|
||||
-> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
|
||||
dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
|
||||
|
||||
dropTableIfExists
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table))
|
||||
=> QualifiedAlias sch tab -- ^ table to remove
|
||||
-> Definition schemas (Alter sch (DropIfExists tab schema) schemas)
|
||||
dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
|
||||
|
||||
-- | `alterTable` changes the definition of a table from the schema.
|
||||
alterTable
|
||||
:: (Has sch schemas schema, Has tab schema ('Table table0))
|
||||
=> QualifiedAlias sch tab -- ^ table to alter
|
||||
-> AlterTable sch tab schemas table1 -- ^ alteration to perform
|
||||
-> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)
|
||||
alterTable tab alteration = UnsafeDefinition $
|
||||
"ALTER TABLE"
|
||||
<+> renderSQL tab
|
||||
<+> renderAlterTable alteration
|
||||
<> ";"
|
||||
|
||||
-- | `alterTableRename` changes the name of a table from the schema.
|
||||
--
|
||||
-- >>> printSQL $ alterTableRename #foo #bar
|
||||
-- ALTER TABLE "foo" RENAME TO "bar";
|
||||
alterTableRename
|
||||
:: (KnownSymbol table0, KnownSymbol table1)
|
||||
=> Alias table0 -- ^ table to rename
|
||||
-> Alias table1 -- ^ what to rename it
|
||||
-> Definition schema (Rename table0 table1 schema)
|
||||
alterTableRename table0 table1 = UnsafeDefinition $
|
||||
"ALTER TABLE" <+> renderSQL table0
|
||||
<+> "RENAME TO" <+> renderSQL table1 <> ";"
|
||||
|
||||
-- | An `AlterTable` describes the alteration to perform on the columns
|
||||
-- of a table.
|
||||
newtype AlterTable
|
||||
(sch :: Symbol)
|
||||
(tab :: Symbol)
|
||||
(schemas :: SchemasType)
|
||||
(table :: TableType) =
|
||||
UnsafeAlterTable {renderAlterTable :: ByteString}
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
|
||||
-- | An `addConstraint` adds a table constraint.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
|
||||
addConstraint
|
||||
:: ( KnownSymbol alias
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns)
|
||||
, table1 ~ (Create alias constraint constraints :=> columns) )
|
||||
=> Alias alias
|
||||
-> TableConstraintExpression sch tab schemas constraint
|
||||
-- ^ constraint to add
|
||||
-> AlterTable sch tab schemas table1
|
||||
addConstraint alias constraint = UnsafeAlterTable $
|
||||
"ADD" <+> "CONSTRAINT" <+> renderSQL alias
|
||||
<+> renderSQL constraint
|
||||
|
||||
-- | A `dropConstraint` drops a table constraint.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- definition = alterTable #tab (dropConstraint #positive)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
|
||||
dropConstraint
|
||||
:: ( KnownSymbol constraint
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns)
|
||||
, table1 ~ (Drop constraint constraints :=> columns) )
|
||||
=> Alias constraint
|
||||
-- ^ constraint to drop
|
||||
-> AlterTable sch tab schemas table1
|
||||
dropConstraint constraint = UnsafeAlterTable $
|
||||
"DROP" <+> "CONSTRAINT" <+> renderSQL constraint
|
||||
|
||||
-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
|
||||
class AddColumn ty where
|
||||
-- | `addColumn` adds a new column, initially filled with whatever
|
||||
-- default value is given or with @NULL@.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=>
|
||||
-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
|
||||
-- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
|
||||
-- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=>
|
||||
-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
|
||||
-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
|
||||
-- definition = alterTable #tab (addColumn #col2 (text & nullable))
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
|
||||
addColumn
|
||||
:: ( KnownSymbol column
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns) )
|
||||
=> Alias column -- ^ column to add
|
||||
-> ColumnTypeExpression schemas ty -- ^ type of the new column
|
||||
-> AlterTable sch tab schemas (constraints :=> Create column ty columns)
|
||||
addColumn column ty = UnsafeAlterTable $
|
||||
"ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
|
||||
instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
|
||||
instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
|
||||
|
||||
-- | A `dropColumn` removes a column. Whatever data was in the column
|
||||
-- disappears. Table constraints involving the column are dropped, too.
|
||||
-- However, if the column is referenced by a foreign key constraint of
|
||||
-- another table, PostgreSQL will not silently drop that constraint.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=>
|
||||
-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
|
||||
-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- definition = alterTable #tab (dropColumn #col2)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" DROP COLUMN "col2";
|
||||
dropColumn
|
||||
:: ( KnownSymbol column
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns)
|
||||
, table1 ~ (constraints :=> Drop column columns) )
|
||||
=> Alias column -- ^ column to remove
|
||||
-> AlterTable sch tab schemas table1
|
||||
dropColumn column = UnsafeAlterTable $
|
||||
"DROP COLUMN" <+> renderSQL column
|
||||
|
||||
-- | A `renameColumn` renames a column.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- definition = alterTable #tab (renameColumn #foo #bar)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
|
||||
renameColumn
|
||||
:: ( KnownSymbol column0
|
||||
, KnownSymbol column1
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns)
|
||||
, table1 ~ (constraints :=> Rename column0 column1 columns) )
|
||||
=> Alias column0 -- ^ column to rename
|
||||
-> Alias column1 -- ^ what to rename the column
|
||||
-> AlterTable sch tab schemas table1
|
||||
renameColumn column0 column1 = UnsafeAlterTable $
|
||||
"RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
|
||||
|
||||
-- | An `alterColumn` alters a single column.
|
||||
alterColumn
|
||||
:: ( KnownSymbol column
|
||||
, Has sch schemas schema
|
||||
, Has tab schema ('Table table0)
|
||||
, table0 ~ (constraints :=> columns)
|
||||
, Has column columns ty0
|
||||
, table1 ~ (constraints :=> Alter column ty1 columns))
|
||||
=> Alias column -- ^ column to alter
|
||||
-> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
|
||||
-> AlterTable sch tab schemas table1
|
||||
alterColumn column alteration = UnsafeAlterTable $
|
||||
"ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
|
||||
|
||||
-- | An `AlterColumn` describes the alteration to perform on a single column.
|
||||
newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
|
||||
UnsafeAlterColumn {renderAlterColumn :: ByteString}
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
|
||||
-- | A `setDefault` sets a new default for a column. Note that this doesn't
|
||||
-- affect any existing rows in the table, it just changes the default for
|
||||
-- future insert and update commands.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
|
||||
-- definition = alterTable #tab (alterColumn #col (setDefault 5))
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
|
||||
setDefault
|
||||
:: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
|
||||
-> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
|
||||
setDefault expression = UnsafeAlterColumn $
|
||||
"SET DEFAULT" <+> renderExpression expression
|
||||
|
||||
-- | A `dropDefault` removes any default value for a column.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- definition = alterTable #tab (alterColumn #col dropDefault)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
|
||||
dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
|
||||
dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
|
||||
|
||||
-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
|
||||
-- The constraint will be checked immediately, so the table data must satisfy
|
||||
-- the constraint before it can be added.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- definition = alterTable #tab (alterColumn #col setNotNull)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
|
||||
setNotNull
|
||||
:: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
|
||||
setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
|
||||
|
||||
-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- definition = alterTable #tab (alterColumn #col dropNotNull)
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
|
||||
dropNotNull
|
||||
:: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
|
||||
dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
|
||||
|
||||
-- | An `alterType` converts a column to a different data type.
|
||||
-- This will succeed only if each existing entry in the column can be
|
||||
-- converted to the new type by an implicit cast.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
|
||||
-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
|
||||
-- definition =
|
||||
-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
|
||||
alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
|
||||
alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
|
||||
@ -0,0 +1,105 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Table.Column
|
||||
Description: Column type expressions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Column type expressions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Table.Column
|
||||
( ColumnTypeExpression (..)
|
||||
, nullable
|
||||
, notNullable
|
||||
, default_
|
||||
, serial2
|
||||
, smallserial
|
||||
, serial4
|
||||
, serial
|
||||
, serial8
|
||||
, bigserial
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
-- | `ColumnTypeExpression`s are used in `createTable` commands.
|
||||
newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
|
||||
= UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL (ColumnTypeExpression schemas ty) where
|
||||
renderSQL = renderColumnTypeExpression
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to note that
|
||||
-- @NULL@ may be present in a column
|
||||
nullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
|
||||
nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to ensure
|
||||
-- @NULL@ is not present in a column
|
||||
notNullable
|
||||
:: TypeExpression schemas (nullity ty)
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
|
||||
notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
|
||||
|
||||
-- | used in `createTable` commands as a column constraint to give a default
|
||||
default_
|
||||
:: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
|
||||
-> ColumnTypeExpression schemas ('NoDef :=> ty)
|
||||
-> ColumnTypeExpression schemas ('Def :=> ty)
|
||||
default_ x ty = UnsafeColumnTypeExpression $
|
||||
renderSQL ty <+> "DEFAULT" <+> renderExpression x
|
||||
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint2`
|
||||
serial2, smallserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
|
||||
serial2 = UnsafeColumnTypeExpression "serial2"
|
||||
smallserial = UnsafeColumnTypeExpression "smallserial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint4`
|
||||
serial4, serial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
|
||||
serial4 = UnsafeColumnTypeExpression "serial4"
|
||||
serial = UnsafeColumnTypeExpression "serial"
|
||||
-- | not a true type, but merely a notational convenience for creating
|
||||
-- unique identifier columns with type `PGint8`
|
||||
serial8, bigserial
|
||||
:: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
|
||||
serial8 = UnsafeColumnTypeExpression "serial8"
|
||||
bigserial = UnsafeColumnTypeExpression "bigserial"
|
||||
@ -0,0 +1,339 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
Description: Table constraint expressions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Table constraint expressions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
( TableConstraintExpression (..)
|
||||
, check
|
||||
, unique
|
||||
, primaryKey
|
||||
, foreignKey
|
||||
, ForeignKeyed
|
||||
, OnDeleteClause (..)
|
||||
, OnUpdateClause (..)
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.ByteString
|
||||
import GHC.TypeLits
|
||||
|
||||
import qualified Generics.SOP as SOP
|
||||
import qualified GHC.Generics as GHC
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression.Logic
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
-- | Data types are a way to limit the kind of data that can be stored in a
|
||||
-- table. For many applications, however, the constraint they provide is
|
||||
-- too coarse. For example, a column containing a product price should
|
||||
-- probably only accept positive values. But there is no standard data type
|
||||
-- that accepts only positive numbers. Another issue is that you might want
|
||||
-- to constrain column data with respect to other columns or rows.
|
||||
-- For example, in a table containing product information,
|
||||
-- there should be only one row for each product number.
|
||||
-- `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.
|
||||
newtype TableConstraintExpression
|
||||
(sch :: Symbol)
|
||||
(tab :: Symbol)
|
||||
(schemas :: SchemasType)
|
||||
(constraint :: TableConstraint)
|
||||
= UnsafeTableConstraintExpression
|
||||
{ renderTableConstraintExpression :: ByteString }
|
||||
deriving (GHC.Generic,Show,Eq,Ord,NFData)
|
||||
instance RenderSQL
|
||||
(TableConstraintExpression sch tab schemas constraint) where
|
||||
renderSQL = renderTableConstraintExpression
|
||||
|
||||
{-| A `check` constraint is the most generic `TableConstraint` type.
|
||||
It allows you to specify that the value in a certain column must satisfy
|
||||
a Boolean (truth-value) expression.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'NotNull 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'NotNull 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & notNullable) `as` #a :*
|
||||
(int & notNullable) `as` #b )
|
||||
( check (#a :* #b) (#a .> #b) `as` #inequality )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
|
||||
-}
|
||||
check
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which are getting checked
|
||||
-> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
|
||||
-- ^ a closed `Condition` on those subcolumns
|
||||
-> TableConstraintExpression sch tab schemas ('Check aliases)
|
||||
check _cols condition = UnsafeTableConstraintExpression $
|
||||
"CHECK" <+> parenthesized (renderSQL condition)
|
||||
|
||||
{-| A `unique` constraint ensure that the data contained in a column,
|
||||
or a group of columns, is unique among all the rows in the table.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
|
||||
"a" ::: 'NoDef :=> 'Null 'PGint4,
|
||||
"b" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( (int & nullable) `as` #a :*
|
||||
(int & nullable) `as` #b )
|
||||
( unique (#a :* #b) `as` #uq_a_b )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
|
||||
-}
|
||||
unique
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema('Table table)
|
||||
, HasAll aliases (TableToRow table) subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify subcolumns which together are unique for each row
|
||||
-> TableConstraintExpression sch tab schemas ('Unique aliases)
|
||||
unique columns = UnsafeTableConstraintExpression $
|
||||
"UNIQUE" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `primaryKey` constraint indicates that a column, or group of columns,
|
||||
can be used as a unique identifier for rows in the table.
|
||||
This requires that the values be both unique and not null.
|
||||
|
||||
>>> :{
|
||||
type Schema = '[
|
||||
"tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
|
||||
"id" ::: 'Def :=> 'NotNull 'PGint4,
|
||||
"name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition (Public '[]) (Public Schema)
|
||||
definition = createTable #tab
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_id )
|
||||
:}
|
||||
|
||||
>>> printSQL definition
|
||||
CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
|
||||
-}
|
||||
primaryKey
|
||||
:: ( Has sch schemas schema
|
||||
, Has tab schema ('Table table)
|
||||
, HasAll aliases (TableToColumns table) subcolumns
|
||||
, AllNotNull subcolumns )
|
||||
=> NP Alias aliases
|
||||
-- ^ specify the subcolumns which together form a primary key.
|
||||
-> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
|
||||
primaryKey columns = UnsafeTableConstraintExpression $
|
||||
"PRIMARY KEY" <+> parenthesized (renderSQL columns)
|
||||
|
||||
{-| A `foreignKey` specifies that the values in a column
|
||||
(or a group of columns) must match the values appearing in some row of
|
||||
another table. We say this maintains the referential integrity
|
||||
between two related tables.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "users" ::: 'Table (
|
||||
'[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
])
|
||||
, "emails" ::: 'Table (
|
||||
'[ "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
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #users
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name )
|
||||
( primaryKey #id `as` #pk_users ) >>>
|
||||
createTable #emails
|
||||
( serial `as` #id :*
|
||||
(int & notNullable) `as` #user_id :*
|
||||
(text & nullable) `as` #email )
|
||||
( primaryKey #id `as` #pk_emails :*
|
||||
foreignKey #user_id #users #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
|
||||
CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
|
||||
|
||||
A `foreignKey` can even be a table self-reference.
|
||||
|
||||
>>> :{
|
||||
type Schema =
|
||||
'[ "employees" ::: 'Table (
|
||||
'[ "employees_pk" ::: 'PrimaryKey '["id"]
|
||||
, "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
|
||||
] :=>
|
||||
'[ "id" ::: 'Def :=> 'NotNull 'PGint4
|
||||
, "name" ::: 'NoDef :=> 'NotNull 'PGtext
|
||||
, "employer_id" ::: 'NoDef :=> 'Null 'PGint4
|
||||
])
|
||||
]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) (Public Schema)
|
||||
setup =
|
||||
createTable #employees
|
||||
( serial `as` #id :*
|
||||
(text & notNullable) `as` #name :*
|
||||
(integer & nullable) `as` #employer_id )
|
||||
( primaryKey #id `as` #employees_pk :*
|
||||
foreignKey #employer_id #employees #id
|
||||
OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
|
||||
-}
|
||||
foreignKey
|
||||
:: (ForeignKeyed schemas sch schema child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys )
|
||||
=> NP Alias columns
|
||||
-- ^ column or columns in the table
|
||||
-> Alias parent
|
||||
-- ^ reference table
|
||||
-> NP Alias refcolumns
|
||||
-- ^ reference column or columns in the reference table
|
||||
-> OnDeleteClause
|
||||
-- ^ what to do when reference is deleted
|
||||
-> OnUpdateClause
|
||||
-- ^ what to do when reference is updated
|
||||
-> TableConstraintExpression sch child schemas
|
||||
('ForeignKey columns parent refcolumns)
|
||||
foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
|
||||
"FOREIGN KEY" <+> parenthesized (renderSQL keys)
|
||||
<+> "REFERENCES" <+> renderSQL parent
|
||||
<+> parenthesized (renderSQL refs)
|
||||
<+> renderSQL ondel
|
||||
<+> renderSQL onupd
|
||||
|
||||
-- | A constraint synonym between types involved in a foreign key constraint.
|
||||
type ForeignKeyed schemas
|
||||
sch
|
||||
schema
|
||||
child parent
|
||||
table reftable
|
||||
columns refcolumns
|
||||
constraints cols
|
||||
reftys tys =
|
||||
( Has sch schemas schema
|
||||
, Has child schema ('Table table)
|
||||
, Has parent schema ('Table reftable)
|
||||
, HasAll columns (TableToColumns table) tys
|
||||
, reftable ~ (constraints :=> cols)
|
||||
, HasAll refcolumns cols reftys
|
||||
, SOP.AllZip SamePGType tys reftys
|
||||
, Uniquely refcolumns constraints )
|
||||
|
||||
-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
|
||||
data OnDeleteClause
|
||||
= OnDeleteNoAction
|
||||
-- ^ if any referencing rows still exist when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnDeleteRestrict -- ^ prevents deletion of a referenced row
|
||||
| OnDeleteCascade
|
||||
-- ^ specifies that when a referenced row is deleted,
|
||||
-- row(s) referencing it should be automatically deleted as well
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnDeleteClause
|
||||
-- | Render `OnDeleteClause`.
|
||||
instance RenderSQL OnDeleteClause where
|
||||
renderSQL = \case
|
||||
OnDeleteNoAction -> "ON DELETE NO ACTION"
|
||||
OnDeleteRestrict -> "ON DELETE RESTRICT"
|
||||
OnDeleteCascade -> "ON DELETE CASCADE"
|
||||
|
||||
-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
|
||||
-- when a referenced column is changed (updated).
|
||||
data OnUpdateClause
|
||||
= OnUpdateNoAction
|
||||
-- ^ if any referencing rows has not changed when the constraint is checked,
|
||||
-- an error is raised
|
||||
| OnUpdateRestrict -- ^ prevents update of a referenced row
|
||||
| OnUpdateCascade
|
||||
-- ^ the updated values of the referenced column(s) should be copied
|
||||
-- into the referencing row(s)
|
||||
deriving (GHC.Generic,Show,Eq,Ord)
|
||||
instance NFData OnUpdateClause
|
||||
|
||||
-- | Render `OnUpdateClause`.
|
||||
instance RenderSQL OnUpdateClause where
|
||||
renderSQL = \case
|
||||
OnUpdateNoAction -> "ON UPDATE NO ACTION"
|
||||
OnUpdateRestrict -> "ON UPDATE RESTRICT"
|
||||
OnUpdateCascade -> "ON UPDATE CASCADE"
|
||||
229
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs
Normal file
229
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs
Normal file
@ -0,0 +1,229 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.Type
|
||||
Description: Create and drop type definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create and drop type definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.Type
|
||||
( createTypeEnum
|
||||
, createTypeEnumFrom
|
||||
, createTypeComposite
|
||||
, createTypeCompositeFrom
|
||||
, createTypeRange
|
||||
, createDomain
|
||||
, dropType
|
||||
, dropTypeIfExists
|
||||
) where
|
||||
|
||||
import Data.ByteString
|
||||
import Data.Monoid
|
||||
import GHC.TypeLits
|
||||
import Prelude hiding ((.), id)
|
||||
|
||||
import qualified Generics.SOP as SOP
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression.Logic
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.PG
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
-- >>> import qualified GHC.Generics as GHC
|
||||
-- >>> import qualified Generics.SOP as SOP
|
||||
|
||||
-- | Enumerated types are created using the `createTypeEnum` command, for example
|
||||
--
|
||||
-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
|
||||
-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
|
||||
createTypeEnum
|
||||
:: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
|
||||
=> QualifiedAlias sch enum
|
||||
-- ^ name of the user defined enumerated type
|
||||
-> NP PGlabel labels
|
||||
-- ^ labels of the enumerated type
|
||||
-> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
|
||||
createTypeEnum enum labels = UnsafeDefinition $
|
||||
"CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
|
||||
parenthesized (renderSQL labels) <> ";"
|
||||
|
||||
-- | Enumerated types can also be generated from a Haskell type, for example
|
||||
--
|
||||
-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
|
||||
-- >>> instance SOP.Generic Schwarma
|
||||
-- >>> instance SOP.HasDatatypeInfo Schwarma
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
|
||||
-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
|
||||
-- in
|
||||
-- printSQL createSchwarma
|
||||
-- :}
|
||||
-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
|
||||
createTypeEnumFrom
|
||||
:: forall hask sch enum schemas schema.
|
||||
( SOP.Generic hask
|
||||
, SOP.All KnownSymbol (LabelsPG hask)
|
||||
, KnownSymbol enum
|
||||
, Has sch schemas schema )
|
||||
=> QualifiedAlias sch enum
|
||||
-- ^ name of the user defined enumerated type
|
||||
-> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
|
||||
createTypeEnumFrom enum = createTypeEnum enum
|
||||
(SOP.hpure label :: NP PGlabel (LabelsPG hask))
|
||||
|
||||
{- | `createTypeComposite` creates a composite type. The composite type is
|
||||
specified by a list of attribute names and data types.
|
||||
|
||||
>>> :{
|
||||
type PGcomplex = 'PGcomposite
|
||||
'[ "real" ::: 'NotNull 'PGfloat8
|
||||
, "imaginary" ::: 'NotNull 'PGfloat8 ]
|
||||
:}
|
||||
|
||||
>>> :{
|
||||
let
|
||||
setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
|
||||
setup = createTypeComposite #complex
|
||||
(float8 `as` #real :* float8 `as` #imaginary)
|
||||
in printSQL setup
|
||||
:}
|
||||
CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
|
||||
-}
|
||||
createTypeComposite
|
||||
:: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
|
||||
=> QualifiedAlias sch ty
|
||||
-- ^ name of the user defined composite type
|
||||
-> NP (Aliased (TypeExpression schemas)) fields
|
||||
-- ^ list of attribute names and data types
|
||||
-> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
|
||||
createTypeComposite ty fields = UnsafeDefinition $
|
||||
"CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
|
||||
(renderCommaSeparated renderField fields) <> ";"
|
||||
where
|
||||
renderField :: Aliased (TypeExpression schemas) x -> ByteString
|
||||
renderField (typ `As` alias) =
|
||||
renderSQL alias <+> renderSQL typ
|
||||
|
||||
-- | Composite types can also be generated from a Haskell type, for example
|
||||
--
|
||||
-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
|
||||
-- >>> instance SOP.Generic Complex
|
||||
-- >>> instance SOP.HasDatatypeInfo Complex
|
||||
-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- createComplex :: Definition (Public '[]) (Public Schema)
|
||||
-- createComplex = createTypeCompositeFrom @Complex #complex
|
||||
-- in
|
||||
-- printSQL createComplex
|
||||
-- :}
|
||||
-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
|
||||
createTypeCompositeFrom
|
||||
:: forall hask sch ty schemas schema.
|
||||
( SOP.All (FieldTyped schemas) (RowPG hask)
|
||||
, KnownSymbol ty
|
||||
, Has sch schemas schema )
|
||||
=> QualifiedAlias sch ty
|
||||
-- ^ name of the user defined composite type
|
||||
-> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
|
||||
createTypeCompositeFrom ty = createTypeComposite ty
|
||||
(SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
|
||||
:: NP (Aliased (TypeExpression schemas)) (RowPG hask))
|
||||
|
||||
{-|
|
||||
`createDomain` creates a new domain. A domain is essentially a data type
|
||||
with constraints (restrictions on the allowed set of values).
|
||||
|
||||
Domains are useful for abstracting common constraints on fields
|
||||
into a single location for maintenance. For example, several tables might
|
||||
contain email address columns, all requiring the same `check` constraint
|
||||
to verify the address syntax. Define a domain rather than setting up
|
||||
each table's constraint individually.
|
||||
|
||||
>>> :{
|
||||
let
|
||||
createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
|
||||
createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
|
||||
in printSQL createPositive
|
||||
:}
|
||||
CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
|
||||
-}
|
||||
createDomain
|
||||
:: (Has sch schemas schema, KnownSymbol dom)
|
||||
=> QualifiedAlias sch dom
|
||||
-> (forall null. TypeExpression schemas (null ty))
|
||||
-> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
|
||||
-> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
|
||||
createDomain dom ty condition =
|
||||
UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
|
||||
<+> "AS" <+> renderTypeExpression ty
|
||||
<+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
|
||||
|
||||
{- |
|
||||
>>> :{
|
||||
let
|
||||
createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
|
||||
createSmallIntRange = createTypeRange #int2range int2
|
||||
in printSQL createSmallIntRange
|
||||
:}
|
||||
CREATE TYPE "int2range" AS RANGE (subtype = int2);
|
||||
-}
|
||||
createTypeRange
|
||||
:: (Has sch schemas schema, KnownSymbol range)
|
||||
=> QualifiedAlias sch range
|
||||
-> (forall null. TypeExpression schemas (null ty))
|
||||
-> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
|
||||
createTypeRange range ty = UnsafeDefinition $
|
||||
"CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
|
||||
parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
|
||||
|
||||
-- | Drop a type.
|
||||
--
|
||||
-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
|
||||
-- >>> instance SOP.Generic Schwarma
|
||||
-- >>> instance SOP.HasDatatypeInfo Schwarma
|
||||
-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
|
||||
-- DROP TYPE "schwarma";
|
||||
dropType
|
||||
:: (Has sch schemas schema, KnownSymbol td)
|
||||
=> QualifiedAlias sch td
|
||||
-- ^ name of the user defined type
|
||||
-> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
|
||||
dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
|
||||
|
||||
dropTypeIfExists
|
||||
:: (Has sch schemas schema, KnownSymbol td)
|
||||
=> QualifiedAlias sch td
|
||||
-- ^ name of the user defined type
|
||||
-> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
|
||||
dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
|
||||
104
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs
Normal file
104
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs
Normal file
@ -0,0 +1,104 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Definition.View
|
||||
Description: Create and drop view definitions
|
||||
Copyright: (c) Eitan Chatav, 2017
|
||||
Maintainer: eitan@morphism.tech
|
||||
Stability: experimental
|
||||
|
||||
Create and drop view definitions.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE
|
||||
AllowAmbiguousTypes
|
||||
, ConstraintKinds
|
||||
, DeriveAnyClass
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedLabels
|
||||
, OverloadedStrings
|
||||
, RankNTypes
|
||||
, ScopedTypeVariables
|
||||
, TypeApplications
|
||||
, TypeInType
|
||||
, TypeOperators
|
||||
, UndecidableSuperClasses
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Definition.View
|
||||
( createView
|
||||
, createOrReplaceView
|
||||
, dropView
|
||||
, dropViewIfExists
|
||||
) where
|
||||
|
||||
import GHC.TypeLits
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Query
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- $setup
|
||||
-- >>> import Squeal.PostgreSQL
|
||||
|
||||
{- | Create a view.
|
||||
>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
|
||||
>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
|
||||
>>> :{
|
||||
let
|
||||
definition :: Definition
|
||||
'[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
|
||||
'[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
|
||||
definition =
|
||||
createView #bc (select_ (#b :* #c) (from (table #abc)))
|
||||
in printSQL definition
|
||||
:}
|
||||
CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
|
||||
-}
|
||||
createView
|
||||
:: (Has sch schemas schema, KnownSymbol vw)
|
||||
=> QualifiedAlias sch vw -- ^ the name of the view to add
|
||||
-> Query '[] '[] schemas '[] view -- ^ query
|
||||
-> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
|
||||
createView alias query = UnsafeDefinition $
|
||||
"CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
|
||||
<+> renderQuery query <> ";"
|
||||
|
||||
createOrReplaceView
|
||||
:: (Has sch schemas schema, KnownSymbol vw)
|
||||
=> QualifiedAlias sch vw -- ^ the name of the view to add
|
||||
-> Query '[] '[] schemas '[] view -- ^ query
|
||||
-> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
|
||||
createOrReplaceView alias query = UnsafeDefinition $
|
||||
"CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
|
||||
<+> renderQuery query <> ";"
|
||||
|
||||
-- | Drop a view.
|
||||
--
|
||||
-- >>> :{
|
||||
-- let
|
||||
-- definition :: Definition
|
||||
-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
|
||||
-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
|
||||
-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
|
||||
-- definition = dropView #bc
|
||||
-- in printSQL definition
|
||||
-- :}
|
||||
-- DROP VIEW "bc";
|
||||
dropView
|
||||
:: (Has sch schemas schema, KnownSymbol vw)
|
||||
=> QualifiedAlias sch vw -- ^ view to remove
|
||||
-> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
|
||||
dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
|
||||
|
||||
dropViewIfExists
|
||||
:: (Has sch schemas schema, KnownSymbol vw)
|
||||
=> QualifiedAlias sch vw -- ^ view to remove
|
||||
-> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
|
||||
dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
|
||||
@ -34,7 +34,7 @@ module Squeal.PostgreSQL.Expression
|
||||
( -- * Expression
|
||||
Expression (..)
|
||||
, Expr
|
||||
, (:-->)
|
||||
, type (-->)
|
||||
, FunctionDB
|
||||
, unsafeFunction
|
||||
, function
|
||||
@ -48,7 +48,7 @@ module Squeal.PostgreSQL.Expression
|
||||
, binaryOp
|
||||
, FunctionVar
|
||||
, unsafeFunctionVar
|
||||
, FunctionN
|
||||
, type (--->)
|
||||
, FunctionNDB
|
||||
, unsafeFunctionN
|
||||
, functionN
|
||||
@ -159,7 +159,7 @@ type OperatorDB schemas x1 x2 y
|
||||
-- This is a subtype of the usual Haskell function type `Prelude.->`,
|
||||
-- indeed a subcategory as it is closed under the usual
|
||||
-- `Prelude..` and `Prelude.id`.
|
||||
type (:-->) x y
|
||||
type (-->) x y
|
||||
= forall outer commons grp schemas params from
|
||||
. Expression outer commons grp schemas params from x
|
||||
-- ^ input
|
||||
@ -179,7 +179,7 @@ Use the `*:` operator to end your argument lists, like so.
|
||||
>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
|
||||
fun(TRUE, FALSE, LOCALTIME, TRUE)
|
||||
-}
|
||||
type FunctionN xs y
|
||||
type (--->) xs y
|
||||
= forall outer commons grp schemas params from
|
||||
. NP (Expression outer commons grp schemas params from) xs
|
||||
-- ^ inputs
|
||||
@ -327,7 +327,7 @@ binaryOp = unsafeBinaryOp $ renderSymbol @op
|
||||
|
||||
-- | >>> printSQL $ unsafeLeftOp "NOT" true
|
||||
-- (NOT TRUE)
|
||||
unsafeLeftOp :: ByteString -> x :--> y
|
||||
unsafeLeftOp :: ByteString -> x --> y
|
||||
unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
|
||||
|
||||
leftOp
|
||||
@ -339,7 +339,7 @@ leftOp = unsafeLeftOp $ renderSymbol @op
|
||||
|
||||
-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
|
||||
-- (TRUE IS NOT TRUE)
|
||||
unsafeRightOp :: ByteString -> x :--> y
|
||||
unsafeRightOp :: ByteString -> x --> y
|
||||
unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
|
||||
|
||||
rightOp
|
||||
@ -351,25 +351,25 @@ rightOp = unsafeRightOp $ renderSymbol @op
|
||||
|
||||
-- | >>> printSQL $ unsafeFunction "f" true
|
||||
-- f(TRUE)
|
||||
unsafeFunction :: ByteString -> x :--> y
|
||||
unsafeFunction :: ByteString -> x --> y
|
||||
unsafeFunction fun x = UnsafeExpression $
|
||||
fun <> parenthesized (renderSQL x)
|
||||
|
||||
function
|
||||
:: (Has sch schemas schema, Has fun schema ('Function '[x] ('Returns y)))
|
||||
:: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
|
||||
=> QualifiedAlias sch fun
|
||||
-> FunctionDB schemas x y
|
||||
function = unsafeFunction . renderSQL
|
||||
|
||||
-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
|
||||
-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
|
||||
unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y
|
||||
unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
|
||||
unsafeFunctionN fun xs = UnsafeExpression $
|
||||
fun <> parenthesized (renderCommaSeparated renderSQL xs)
|
||||
|
||||
functionN
|
||||
:: ( Has sch schemas schema
|
||||
, Has fun schema ('Function xs ('Returns y))
|
||||
, Has fun schema ('Function (xs :=> 'Returns y))
|
||||
, SListI xs )
|
||||
=> QualifiedAlias sch fun
|
||||
-> FunctionNDB schemas xs y
|
||||
|
||||
@ -42,7 +42,7 @@ import qualified Generics.SOP as SOP
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.SetOf
|
||||
import Squeal.PostgreSQL.Expression.Set
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Render
|
||||
import Squeal.PostgreSQL.Schema
|
||||
@ -111,20 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>
|
||||
|
||||
-- | >>> printSQL $ cardinality (array [null_, false, true])
|
||||
-- cardinality(ARRAY[NULL, FALSE, TRUE])
|
||||
cardinality :: null ('PGvararray ty) :--> null 'PGint8
|
||||
cardinality :: null ('PGvararray ty) --> null 'PGint8
|
||||
cardinality = unsafeFunction "cardinality"
|
||||
|
||||
-- | >>> printSQL $ array [null_, false, true] & index 2
|
||||
-- (ARRAY[NULL, FALSE, TRUE])[2]
|
||||
index
|
||||
:: Word64 -- ^ index
|
||||
-> null ('PGvararray ty) :--> NullifyType ty
|
||||
-> null ('PGvararray ty) --> NullifyType ty
|
||||
index n expr = UnsafeExpression $
|
||||
parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
|
||||
|
||||
-- | Expand an array to a set of rows
|
||||
unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
|
||||
unnest = unsafeSetOfFunction
|
||||
unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
|
||||
unnest = unsafeSetFunction
|
||||
|
||||
-- | A row constructor is an expression that builds a row value
|
||||
-- (also called a composite value) using values for its member fields.
|
||||
|
||||
@ -162,7 +162,7 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
|
||||
>>> printSQL $ true & isTrue
|
||||
(TRUE IS TRUE)
|
||||
-}
|
||||
isTrue :: null0 'PGbool :--> null1 'PGbool
|
||||
isTrue :: null0 'PGbool --> null1 'PGbool
|
||||
isTrue = unsafeRightOp "IS TRUE"
|
||||
|
||||
{- | is false or unknown
|
||||
@ -170,7 +170,7 @@ isTrue = unsafeRightOp "IS TRUE"
|
||||
>>> printSQL $ true & isNotTrue
|
||||
(TRUE IS NOT TRUE)
|
||||
-}
|
||||
isNotTrue :: null0 'PGbool :--> null1 'PGbool
|
||||
isNotTrue :: null0 'PGbool --> null1 'PGbool
|
||||
isNotTrue = unsafeRightOp "IS NOT TRUE"
|
||||
|
||||
{- | is false
|
||||
@ -178,7 +178,7 @@ isNotTrue = unsafeRightOp "IS NOT TRUE"
|
||||
>>> printSQL $ true & isFalse
|
||||
(TRUE IS FALSE)
|
||||
-}
|
||||
isFalse :: null0 'PGbool :--> null1 'PGbool
|
||||
isFalse :: null0 'PGbool --> null1 'PGbool
|
||||
isFalse = unsafeRightOp "IS FALSE"
|
||||
|
||||
{- | is true or unknown
|
||||
@ -186,7 +186,7 @@ isFalse = unsafeRightOp "IS FALSE"
|
||||
>>> printSQL $ true & isNotFalse
|
||||
(TRUE IS NOT FALSE)
|
||||
-}
|
||||
isNotFalse :: null0 'PGbool :--> null1 'PGbool
|
||||
isNotFalse :: null0 'PGbool --> null1 'PGbool
|
||||
isNotFalse = unsafeRightOp "IS NOT FALSE"
|
||||
|
||||
{- | is unknown
|
||||
@ -194,7 +194,7 @@ isNotFalse = unsafeRightOp "IS NOT FALSE"
|
||||
>>> printSQL $ true & isUnknown
|
||||
(TRUE IS UNKNOWN)
|
||||
-}
|
||||
isUnknown :: null0 'PGbool :--> null1 'PGbool
|
||||
isUnknown :: null0 'PGbool --> null1 'PGbool
|
||||
isUnknown = unsafeRightOp "IS UNKNOWN"
|
||||
|
||||
{- | is true or false
|
||||
@ -202,5 +202,5 @@ isUnknown = unsafeRightOp "IS UNKNOWN"
|
||||
>>> printSQL $ true & isNotUnknown
|
||||
(TRUE IS NOT UNKNOWN)
|
||||
-}
|
||||
isNotUnknown :: null0 'PGbool :--> null1 'PGbool
|
||||
isNotUnknown :: null0 'PGbool --> null1 'PGbool
|
||||
isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
|
||||
|
||||
@ -81,7 +81,7 @@ import GHC.TypeLits
|
||||
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Expression
|
||||
import Squeal.PostgreSQL.Expression.SetOf
|
||||
import Squeal.PostgreSQL.Expression.Set
|
||||
import Squeal.PostgreSQL.Expression.Type
|
||||
import Squeal.PostgreSQL.List
|
||||
import Squeal.PostgreSQL.Query
|
||||
@ -188,7 +188,7 @@ Table 9.45: JSON creation functions
|
||||
-- otherwise, a scalar value is produced. For any scalar type other than a
|
||||
-- number, a Boolean, or a null value, the text representation will be used, in
|
||||
-- such a fashion that it is a valid json value.
|
||||
toJson :: null ty :--> null 'PGjson
|
||||
toJson :: null ty --> null 'PGjson
|
||||
toJson = unsafeFunction "to_json"
|
||||
|
||||
-- | Returns the value as jsonb. Arrays and composites are converted
|
||||
@ -197,26 +197,26 @@ toJson = unsafeFunction "to_json"
|
||||
-- otherwise, a scalar value is produced. For any scalar type other than a
|
||||
-- number, a Boolean, or a null value, the text representation will be used, in
|
||||
-- such a fashion that it is a valid jsonb value.
|
||||
toJsonb :: null ty :--> null 'PGjsonb
|
||||
toJsonb :: null ty --> null 'PGjsonb
|
||||
toJsonb = unsafeFunction "to_jsonb"
|
||||
|
||||
-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
|
||||
-- becomes a JSON array of arrays.
|
||||
arrayToJson :: null ('PGvararray ty) :--> null 'PGjson
|
||||
arrayToJson :: null ('PGvararray ty) --> null 'PGjson
|
||||
arrayToJson = unsafeFunction "array_to_json"
|
||||
|
||||
-- | Returns the row as a JSON object.
|
||||
rowToJson :: null ('PGcomposite ty) :--> null 'PGjson
|
||||
rowToJson :: null ('PGcomposite ty) --> null 'PGjson
|
||||
rowToJson = unsafeFunction "row_to_json"
|
||||
|
||||
-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
|
||||
-- argument list.
|
||||
jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)
|
||||
jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
|
||||
jsonBuildArray = unsafeFunctionN "json_build_array"
|
||||
|
||||
-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
|
||||
-- variadic argument list.
|
||||
jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)
|
||||
jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
|
||||
jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
|
||||
|
||||
-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
|
||||
@ -224,10 +224,10 @@ jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
|
||||
-- and values.
|
||||
class SOP.SListI tys => JsonBuildObject tys where
|
||||
|
||||
jsonBuildObject :: FunctionN tys (null 'PGjson)
|
||||
jsonBuildObject :: tys ---> null 'PGjson
|
||||
jsonBuildObject = unsafeFunctionN "json_build_object"
|
||||
|
||||
jsonbBuildObject :: FunctionN tys (null 'PGjsonb)
|
||||
jsonbBuildObject :: tys ---> null 'PGjsonb
|
||||
jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
|
||||
|
||||
instance JsonBuildObject '[]
|
||||
@ -240,7 +240,7 @@ instance (JsonBuildObject tys, key `In` PGJsonKey)
|
||||
-- which are taken as a key/value pair.
|
||||
jsonObject
|
||||
:: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
|
||||
:--> null 'PGjson
|
||||
--> null 'PGjson
|
||||
jsonObject = unsafeFunction "json_object"
|
||||
|
||||
-- | Builds a binary JSON object out of a text array.
|
||||
@ -249,24 +249,24 @@ jsonObject = unsafeFunction "json_object"
|
||||
-- which are taken as a key/value pair.
|
||||
jsonbObject
|
||||
:: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
|
||||
:--> null 'PGjsonb
|
||||
--> null 'PGjsonb
|
||||
jsonbObject = unsafeFunction "jsonb_object"
|
||||
|
||||
-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
|
||||
-- keys and one for values, that are zipped pairwise to create a JSON object.
|
||||
jsonZipObject :: FunctionN
|
||||
jsonZipObject ::
|
||||
'[ null ('PGvararray ('NotNull 'PGtext))
|
||||
, null ('PGvararray ('NotNull 'PGtext)) ]
|
||||
( null 'PGjson )
|
||||
---> null 'PGjson
|
||||
jsonZipObject = unsafeFunctionN "json_object"
|
||||
|
||||
-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
|
||||
-- keys and one for values, that are zipped pairwise to create a binary JSON
|
||||
-- object.
|
||||
jsonbZipObject :: FunctionN
|
||||
jsonbZipObject ::
|
||||
'[ null ('PGvararray ('NotNull 'PGtext))
|
||||
, null ('PGvararray ('NotNull 'PGtext)) ]
|
||||
( null 'PGjsonb )
|
||||
---> null 'PGjsonb
|
||||
jsonbZipObject = unsafeFunctionN "jsonb_object"
|
||||
|
||||
{-----------------------------------------
|
||||
@ -274,31 +274,31 @@ Table 9.46: JSON processing functions
|
||||
-----------------------------------------}
|
||||
|
||||
-- | Returns the number of elements in the outermost JSON array.
|
||||
jsonArrayLength :: null 'PGjson :--> null 'PGint4
|
||||
jsonArrayLength :: null 'PGjson --> null 'PGint4
|
||||
jsonArrayLength = unsafeFunction "json_array_length"
|
||||
|
||||
-- | Returns the number of elements in the outermost binary JSON array.
|
||||
jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4
|
||||
jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
|
||||
jsonbArrayLength = unsafeFunction "jsonb_array_length"
|
||||
|
||||
-- | Returns the type of the outermost JSON value as a text string. Possible
|
||||
-- types are object, array, string, number, boolean, and null.
|
||||
jsonTypeof :: null 'PGjson :--> null 'PGtext
|
||||
jsonTypeof :: null 'PGjson --> null 'PGtext
|
||||
jsonTypeof = unsafeFunction "json_typeof"
|
||||
|
||||
-- | Returns the type of the outermost binary JSON value as a text string.
|
||||
-- Possible types are object, array, string, number, boolean, and null.
|
||||
jsonbTypeof :: null 'PGjsonb :--> null 'PGtext
|
||||
jsonbTypeof :: null 'PGjsonb --> null 'PGtext
|
||||
jsonbTypeof = unsafeFunction "jsonb_typeof"
|
||||
|
||||
-- | Returns its argument with all object fields that have null values omitted.
|
||||
-- Other null values are untouched.
|
||||
jsonStripNulls :: null 'PGjson :--> null 'PGjson
|
||||
jsonStripNulls :: null 'PGjson --> null 'PGjson
|
||||
jsonStripNulls = unsafeFunction "json_strip_nulls"
|
||||
|
||||
-- | Returns its argument with all object fields that have null values omitted.
|
||||
-- Other null values are untouched.
|
||||
jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb
|
||||
jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
|
||||
jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
|
||||
|
||||
-- | @ jsonbSet target path new_value create_missing @
|
||||
@ -309,12 +309,9 @@ jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
|
||||
-- item designated by path does not exist. As with the path orientated
|
||||
-- operators, negative integers that appear in path count from the end of JSON
|
||||
-- arrays.
|
||||
jsonbSet
|
||||
:: FunctionN
|
||||
'[ null 'PGjsonb
|
||||
, null ('PGvararray ('NotNull 'PGtext))
|
||||
, null 'PGjsonb
|
||||
, null 'PGbool ] (null 'PGjsonb)
|
||||
jsonbSet ::
|
||||
'[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
|
||||
, null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
|
||||
jsonbSet = unsafeFunctionN "jsonbSet"
|
||||
|
||||
-- | @ jsonbInsert target path new_value insert_after @
|
||||
@ -326,27 +323,23 @@ jsonbSet = unsafeFunctionN "jsonbSet"
|
||||
-- path is in JSONB object, @new_value@ will be inserted only if target does not
|
||||
-- exist. As with the path orientated operators, negative integers that appear
|
||||
-- in path count from the end of JSON arrays.
|
||||
jsonbInsert
|
||||
:: FunctionN
|
||||
'[ null 'PGjsonb
|
||||
, null ('PGvararray ('NotNull 'PGtext))
|
||||
, null 'PGjsonb
|
||||
, null 'PGbool ] (null 'PGjsonb)
|
||||
jsonbInsert ::
|
||||
'[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
|
||||
, null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
|
||||
jsonbInsert = unsafeFunctionN "jsonb_insert"
|
||||
|
||||
-- | Returns its argument as indented JSON text.
|
||||
jsonbPretty :: null 'PGjsonb :--> null 'PGtext
|
||||
jsonbPretty :: null 'PGjsonb --> null 'PGtext
|
||||
jsonbPretty = unsafeFunction "jsonb_pretty"
|
||||
|
||||
|
||||
{- | Expands the outermost JSON object into a set of key/value pairs.
|
||||
|
||||
>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
|
||||
SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
|
||||
-}
|
||||
jsonEach :: SetOfFunction "json_each" (null 'PGjson)
|
||||
jsonEach :: SetFunction "json_each" (null 'PGjson)
|
||||
'["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
|
||||
jsonEach = unsafeSetOfFunction
|
||||
jsonEach = unsafeSetFunction
|
||||
|
||||
{- | Expands the outermost binary JSON object into a set of key/value pairs.
|
||||
|
||||
@ -354,9 +347,9 @@ jsonEach = unsafeSetOfFunction
|
||||
SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
|
||||
-}
|
||||
jsonbEach
|
||||
:: SetOfFunction "jsonb_each" (nullity 'PGjsonb)
|
||||
:: SetFunction "jsonb_each" (nullity 'PGjsonb)
|
||||
'["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
|
||||
jsonbEach = unsafeSetOfFunction
|
||||
jsonbEach = unsafeSetFunction
|
||||
|
||||
{- | Expands the outermost JSON object into a set of key/value pairs.
|
||||
|
||||
@ -364,9 +357,9 @@ jsonbEach = unsafeSetOfFunction
|
||||
SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
|
||||
-}
|
||||
jsonEachText
|
||||
:: SetOfFunction "json_each_text" (null 'PGjson)
|
||||
:: SetFunction "json_each_text" (null 'PGjson)
|
||||
'["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
|
||||
jsonEachText = unsafeSetOfFunction
|
||||
jsonEachText = unsafeSetFunction
|
||||
|
||||
{- | Expands the outermost binary JSON object into a set of key/value pairs.
|
||||
|
||||
@ -374,9 +367,9 @@ jsonEachText = unsafeSetOfFunction
|
||||
SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
|
||||
-}
|
||||
jsonbEachText
|
||||
:: SetOfFunction "jsonb_each_text" (null 'PGjsonb)
|
||||
:: SetFunction "jsonb_each_text" (null 'PGjsonb)
|
||||
'["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
|
||||
jsonbEachText = unsafeSetOfFunction
|
||||
jsonbEachText = unsafeSetFunction
|
||||
|
||||
{- | Returns set of keys in the outermost JSON object.
|
||||
|
||||
@ -384,9 +377,9 @@ jsonbEachText = unsafeSetOfFunction
|
||||
json_object_keys(('{"a":"foo","b":"bar"}' :: json))
|
||||
-}
|
||||
jsonObjectKeys
|
||||
:: SetOfFunction "json_object_keys" (nullity 'PGjson)
|
||||
:: SetFunction "json_object_keys" (nullity 'PGjson)
|
||||
'["json_object_keys" ::: 'NotNull 'PGtext]
|
||||
jsonObjectKeys = unsafeSetOfFunction
|
||||
jsonObjectKeys = unsafeSetFunction
|
||||
|
||||
{- | Returns set of keys in the outermost JSON object.
|
||||
|
||||
@ -394,9 +387,9 @@ jsonObjectKeys = unsafeSetOfFunction
|
||||
jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
|
||||
-}
|
||||
jsonbObjectKeys
|
||||
:: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)
|
||||
:: SetFunction "jsonb_object_keys" (null 'PGjsonb)
|
||||
'["jsonb_object_keys" ::: 'NotNull 'PGtext]
|
||||
jsonbObjectKeys = unsafeSetOfFunction
|
||||
jsonbObjectKeys = unsafeSetFunction
|
||||
|
||||
-- | Build rows from Json types.
|
||||
type JsonPopulateFunction fun json
|
||||
|
||||
@ -47,7 +47,7 @@ false = UnsafeExpression "FALSE"
|
||||
|
||||
-- | >>> printSQL $ not_ true
|
||||
-- (NOT TRUE)
|
||||
not_ :: null 'PGbool :--> null 'PGbool
|
||||
not_ :: null 'PGbool --> null 'PGbool
|
||||
not_ = unsafeLeftOp "NOT"
|
||||
|
||||
-- | >>> printSQL $ true .&& false
|
||||
|
||||
@ -37,9 +37,7 @@ import Squeal.PostgreSQL.Schema
|
||||
-- in printSQL expression
|
||||
-- :}
|
||||
-- atan2(pi(), 2)
|
||||
atan2_
|
||||
:: float `In` PGFloating
|
||||
=> FunctionN '[ null float, null float] (null float)
|
||||
atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
|
||||
atan2_ = unsafeFunctionN "atan2"
|
||||
|
||||
|
||||
@ -78,7 +76,7 @@ rem_ = unsafeBinaryOp "%"
|
||||
-- in printSQL expression
|
||||
-- :}
|
||||
-- trunc(pi())
|
||||
trunc :: frac `In` PGFloating => null frac :--> null frac
|
||||
trunc :: frac `In` PGFloating => null frac --> null frac
|
||||
trunc = unsafeFunction "trunc"
|
||||
|
||||
-- | >>> :{
|
||||
@ -88,7 +86,7 @@ trunc = unsafeFunction "trunc"
|
||||
-- in printSQL expression
|
||||
-- :}
|
||||
-- round(pi())
|
||||
round_ :: frac `In` PGFloating => null frac :--> null frac
|
||||
round_ :: frac `In` PGFloating => null frac --> null frac
|
||||
round_ = unsafeFunction "round"
|
||||
|
||||
-- | >>> :{
|
||||
@ -98,5 +96,5 @@ round_ = unsafeFunction "round"
|
||||
-- in printSQL expression
|
||||
-- :}
|
||||
-- ceiling(pi())
|
||||
ceiling_ :: frac `In` PGFloating => null frac :--> null frac
|
||||
ceiling_ :: frac `In` PGFloating => null frac --> null frac
|
||||
ceiling_ = unsafeFunction "ceiling"
|
||||
|
||||
@ -44,7 +44,7 @@ null_ = UnsafeExpression "NULL"
|
||||
--
|
||||
-- >>> printSQL $ notNull true
|
||||
-- TRUE
|
||||
notNull :: 'NotNull ty :--> 'Null ty
|
||||
notNull :: 'NotNull ty --> 'Null ty
|
||||
notNull = UnsafeExpression . renderSQL
|
||||
|
||||
-- | return the leftmost value which is not NULL
|
||||
@ -69,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx
|
||||
|
||||
-- | >>> printSQL $ null_ & isNull
|
||||
-- NULL IS NULL
|
||||
isNull :: 'Null ty :--> null 'PGbool
|
||||
isNull :: 'Null ty --> null 'PGbool
|
||||
isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
|
||||
|
||||
-- | >>> printSQL $ null_ & isNotNull
|
||||
-- NULL IS NOT NULL
|
||||
isNotNull :: 'Null ty :--> null 'PGbool
|
||||
isNotNull :: 'Null ty --> null 'PGbool
|
||||
isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
|
||||
|
||||
-- | analagous to `maybe` using @IS NULL@
|
||||
@ -100,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y
|
||||
>>> printSQL expr
|
||||
NULLIF(FALSE, ($1 :: bool))
|
||||
-}
|
||||
nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)
|
||||
nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
|
||||
nullIf = unsafeFunctionN "NULLIF"
|
||||
|
||||
@ -205,27 +205,26 @@ whole = NonEmpty Infinite Infinite
|
||||
(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
|
||||
(@-) = unsafeBinaryOp "-"
|
||||
|
||||
lowerBound :: null ('PGrange ty) :--> 'Null ty
|
||||
lowerBound :: null ('PGrange ty) --> 'Null ty
|
||||
lowerBound = unsafeFunction "lower"
|
||||
|
||||
upperBound :: null ('PGrange ty) :--> 'Null ty
|
||||
upperBound :: null ('PGrange ty) --> 'Null ty
|
||||
upperBound = unsafeFunction "upper"
|
||||
|
||||
isEmpty :: null ('PGrange ty) :--> 'Null 'PGbool
|
||||
isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
|
||||
isEmpty = unsafeFunction "isempty"
|
||||
|
||||
lowerInc :: null ('PGrange ty) :--> 'Null 'PGbool
|
||||
lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
|
||||
lowerInc = unsafeFunction "lower_inc"
|
||||
|
||||
lowerInf :: null ('PGrange ty) :--> 'Null 'PGbool
|
||||
lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
|
||||
lowerInf = unsafeFunction "lower_inf"
|
||||
|
||||
upperInc :: null ('PGrange ty) :--> 'Null 'PGbool
|
||||
upperInc :: null ('PGrange ty) --> 'Null 'PGbool
|
||||
upperInc = unsafeFunction "upper_inc"
|
||||
|
||||
upperInf :: null ('PGrange ty) :--> 'Null 'PGbool
|
||||
upperInf :: null ('PGrange ty) --> 'Null 'PGbool
|
||||
upperInf = unsafeFunction "upper_inf"
|
||||
|
||||
rangeMerge :: FunctionN
|
||||
'[ null ('PGrange ty), null ('PGrange ty)] (null ('PGrange ty))
|
||||
rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
|
||||
rangeMerge = unsafeFunctionN "range_merge"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-|
|
||||
Module: Squeal.PostgreSQL.Expression.SetOf
|
||||
Module: Squeal.PostgreSQL.Expression.Set
|
||||
Description: Set returning functions
|
||||
Copyright: (c) Eitan Chatav, 2019
|
||||
Maintainer: eitan@morphism.tech
|
||||
@ -20,16 +20,18 @@ Set returning functions
|
||||
, TypeOperators
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Expression.SetOf
|
||||
module Squeal.PostgreSQL.Expression.Set
|
||||
( generateSeries
|
||||
, generateSeriesStep
|
||||
, generateSeriesTimestamp
|
||||
, SetOfFunction
|
||||
, unsafeSetOfFunction
|
||||
, setOfFunction
|
||||
, SetOfFunctionN
|
||||
, unsafeSetOfFunctionN
|
||||
, setOfFunctionN
|
||||
, SetFunction
|
||||
, unsafeSetFunction
|
||||
, SetFunctionDB
|
||||
, setFunction
|
||||
, SetFunctionN
|
||||
, unsafeSetFunctionN
|
||||
, SetFunctionNDB
|
||||
, setFunctionN
|
||||
) where
|
||||
|
||||
import GHC.TypeLits
|
||||
@ -46,55 +48,65 @@ import Squeal.PostgreSQL.Schema
|
||||
{- |
|
||||
A @RankNType@ for set returning functions with 1 argument.
|
||||
-}
|
||||
type SetOfFunction fun ty setof
|
||||
type SetFunction fun ty row
|
||||
= forall outer commons schemas params
|
||||
. Expression outer commons 'Ungrouped schemas params '[] ty
|
||||
-- ^ input
|
||||
-> FromClause outer commons schemas params '[fun ::: setof]
|
||||
-> FromClause outer commons schemas params '[fun ::: row]
|
||||
-- ^ output
|
||||
|
||||
type SetFunctionDB fun schemas ty row
|
||||
= forall outer commons params
|
||||
. Expression outer commons 'Ungrouped schemas params '[] ty
|
||||
-- ^ input
|
||||
-> FromClause outer commons schemas params '[fun ::: row]
|
||||
-- ^ output
|
||||
|
||||
-- | Escape hatch for a set returning function with 1 argument.
|
||||
unsafeSetOfFunction
|
||||
:: forall fun ty setof. KnownSymbol fun
|
||||
=> SetOfFunction fun ty setof -- ^ set returning function
|
||||
unsafeSetOfFunction x = UnsafeFromClause $
|
||||
unsafeSetFunction
|
||||
:: forall fun ty row. KnownSymbol fun
|
||||
=> SetFunction fun ty row -- ^ set returning function
|
||||
unsafeSetFunction x = UnsafeFromClause $
|
||||
renderSymbol @fun <> parenthesized (renderSQL x)
|
||||
|
||||
setOfFunction
|
||||
setFunction
|
||||
:: ( Has sch schemas schema
|
||||
, Has fun schema ('Function '[ty] ('ReturnsTable setof)) )
|
||||
=> Alias fun
|
||||
-> ( forall outer commons params
|
||||
. Expression outer commons 'Ungrouped schemas params '[] ty
|
||||
-> FromClause outer commons schemas params '[fun ::: setof] )
|
||||
setOfFunction _ = unsafeSetOfFunction
|
||||
, Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
|
||||
=> QualifiedAlias sch fun
|
||||
-> SetFunctionDB fun schemas ty row
|
||||
setFunction _ = unsafeSetFunction
|
||||
|
||||
{- |
|
||||
A @RankNType@ for set returning functions with multiple argument.
|
||||
-}
|
||||
type SetOfFunctionN fun tys setof
|
||||
type SetFunctionN fun tys row
|
||||
= forall outer commons schemas params
|
||||
. NP (Expression outer commons 'Ungrouped schemas params '[]) tys
|
||||
-- ^ inputs
|
||||
-> FromClause outer commons schemas params '[fun ::: setof]
|
||||
-> FromClause outer commons schemas params '[fun ::: row]
|
||||
-- ^ output
|
||||
|
||||
-- | Escape hatch for a set returning function with multiple argument.
|
||||
unsafeSetOfFunctionN
|
||||
:: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)
|
||||
=> SetOfFunctionN fun tys setof -- ^ set returning function
|
||||
unsafeSetOfFunctionN xs = UnsafeFromClause $
|
||||
unsafeSetFunctionN
|
||||
:: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
|
||||
=> SetFunctionN fun tys row -- ^ set returning function
|
||||
unsafeSetFunctionN xs = UnsafeFromClause $
|
||||
renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
|
||||
|
||||
setOfFunctionN
|
||||
type SetFunctionNDB fun schemas tys row
|
||||
= forall outer commons params
|
||||
. NP (Expression outer commons 'Ungrouped schemas params '[]) tys
|
||||
-- ^ inputs
|
||||
-> FromClause outer commons schemas params '[fun ::: row]
|
||||
-- ^ output
|
||||
|
||||
setFunctionN
|
||||
:: ( Has sch schemas schema
|
||||
, Has fun schema ('Function tys ('ReturnsTable setof))
|
||||
, Has fun schema ('Function (tys :=> 'ReturnsTable row))
|
||||
, SOP.SListI tys )
|
||||
=> Alias fun
|
||||
-> ( forall outer commons params
|
||||
. NP (Expression outer commons 'Ungrouped schemas params '[]) tys
|
||||
-> FromClause outer commons schemas params '[fun ::: setof] )
|
||||
setOfFunctionN _ = unsafeSetOfFunctionN
|
||||
=> QualifiedAlias sch fun
|
||||
-> SetFunctionNDB fun schemas tys row
|
||||
setFunctionN _ = unsafeSetFunctionN
|
||||
|
||||
{- | @generateSeries (start *: stop)@
|
||||
|
||||
@ -102,9 +114,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of one
|
||||
-}
|
||||
generateSeries
|
||||
:: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
|
||||
=> SetOfFunctionN "generate_series" '[ null ty, null ty]
|
||||
=> SetFunctionN "generate_series" '[ null ty, null ty]
|
||||
'["generate_series" ::: null ty] -- ^ set returning function
|
||||
generateSeries = unsafeSetOfFunctionN
|
||||
generateSeries = unsafeSetFunctionN
|
||||
|
||||
{- | @generateSeries (start :* stop *: step)@
|
||||
|
||||
@ -112,9 +124,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
|
||||
-}
|
||||
generateSeriesStep
|
||||
:: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
|
||||
=> SetOfFunctionN "generate_series" '[null ty, null ty, null ty]
|
||||
=> SetFunctionN "generate_series" '[null ty, null ty, null ty]
|
||||
'["generate_series" ::: null ty] -- ^ set returning function
|
||||
generateSeriesStep = unsafeSetOfFunctionN
|
||||
generateSeriesStep = unsafeSetFunctionN
|
||||
|
||||
{- | @generateSeries (start :* stop *: step)@
|
||||
|
||||
@ -122,6 +134,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@
|
||||
-}
|
||||
generateSeriesTimestamp
|
||||
:: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
|
||||
=> SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
|
||||
=> SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
|
||||
'["generate_series" ::: null ty] -- ^ set returning function
|
||||
generateSeriesTimestamp = unsafeSetOfFunctionN
|
||||
generateSeriesTimestamp = unsafeSetFunctionN
|
||||
@ -30,17 +30,17 @@ import Squeal.PostgreSQL.Schema
|
||||
|
||||
-- | >>> printSQL $ lower "ARRRGGG"
|
||||
-- lower(E'ARRRGGG')
|
||||
lower :: null 'PGtext :--> null 'PGtext
|
||||
lower :: null 'PGtext --> null 'PGtext
|
||||
lower = unsafeFunction "lower"
|
||||
|
||||
-- | >>> printSQL $ upper "eeee"
|
||||
-- upper(E'eeee')
|
||||
upper :: null 'PGtext :--> null 'PGtext
|
||||
upper :: null 'PGtext --> null 'PGtext
|
||||
upper = unsafeFunction "upper"
|
||||
|
||||
-- | >>> printSQL $ charLength "four"
|
||||
-- char_length(E'four')
|
||||
charLength :: null 'PGtext :--> null 'PGint4
|
||||
charLength :: null 'PGtext --> null 'PGint4
|
||||
charLength = unsafeFunction "char_length"
|
||||
|
||||
-- | The `like` expression returns true if the @string@ matches
|
||||
|
||||
@ -55,7 +55,7 @@ import Squeal.PostgreSQL.Schema
|
||||
(.|) = unsafeBinaryOp "||"
|
||||
|
||||
-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
|
||||
(.!) :: null 'PGtsquery :--> null 'PGtsquery
|
||||
(.!) :: null 'PGtsquery --> null 'PGtsquery
|
||||
(.!) = unsafeLeftOp "!!"
|
||||
|
||||
-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
|
||||
@ -66,51 +66,50 @@ import Squeal.PostgreSQL.Schema
|
||||
-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
arrayToTSvector
|
||||
:: null ('PGvararray ('NotNull 'PGtext))
|
||||
:--> null 'PGtsvector
|
||||
--> null 'PGtsvector
|
||||
arrayToTSvector = unsafeFunction "array_to_tsvector"
|
||||
|
||||
-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
tsvectorLength :: null 'PGtsvector :--> null 'PGint4
|
||||
tsvectorLength :: null 'PGtsvector --> null 'PGint4
|
||||
tsvectorLength = unsafeFunction "length"
|
||||
|
||||
-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
|
||||
numnode :: null 'PGtsquery :--> null 'PGint4
|
||||
numnode :: null 'PGtsquery --> null 'PGint4
|
||||
numnode = unsafeFunction "numnode"
|
||||
|
||||
-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
|
||||
plainToTSquery :: null 'PGtext :--> null 'PGtsquery
|
||||
plainToTSquery :: null 'PGtext --> null 'PGtsquery
|
||||
plainToTSquery = unsafeFunction "plainto_tsquery"
|
||||
|
||||
-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
|
||||
-- ignoring punctuation
|
||||
phraseToTSquery :: null 'PGtext :--> null 'PGtsquery
|
||||
phraseToTSquery :: null 'PGtext --> null 'PGtsquery
|
||||
phraseToTSquery = unsafeFunction "phraseto_tsquery"
|
||||
|
||||
-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
|
||||
websearchToTSquery :: null 'PGtext :--> null 'PGtsquery
|
||||
websearchToTSquery :: null 'PGtext --> null 'PGtsquery
|
||||
websearchToTSquery = unsafeFunction "websearch_to_tsquery"
|
||||
|
||||
-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
|
||||
queryTree :: null 'PGtsquery :--> null 'PGtext
|
||||
queryTree :: null 'PGtsquery --> null 'PGtext
|
||||
queryTree = unsafeFunction "query_tree"
|
||||
|
||||
-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
|
||||
toTSquery :: null 'PGtext :--> null 'PGtsquery
|
||||
toTSquery :: null 'PGtext --> null 'PGtsquery
|
||||
toTSquery = unsafeFunction "to_tsquery"
|
||||
|
||||
-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
toTSvector
|
||||
:: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
|
||||
=> null ty :--> null 'PGtsvector
|
||||
=> null ty --> null 'PGtsvector
|
||||
toTSvector = unsafeFunction "to_tsvector"
|
||||
|
||||
-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
setWeight
|
||||
:: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)
|
||||
setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
|
||||
setWeight = unsafeFunctionN "set_weight"
|
||||
|
||||
-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
strip :: null 'PGtsvector :--> null 'PGtsvector
|
||||
strip :: null 'PGtsvector --> null 'PGtsvector
|
||||
strip = unsafeFunction "strip"
|
||||
|
||||
-- | @jsonToTSvector (document *: filter)@
|
||||
@ -123,7 +122,7 @@ strip = unsafeFunction "strip"
|
||||
-- "boolean" (to include all Boolean values in the string format "true"/"false"),
|
||||
-- "key" (to include all keys) or "all" (to include all above).
|
||||
-- These values can be combined together to include, e.g. all string and numeric values.
|
||||
jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)
|
||||
jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
|
||||
jsonToTSvector = unsafeFunctionN "json_to_tsvector"
|
||||
|
||||
-- | @jsonbToTSvector (document *: filter)@
|
||||
@ -136,23 +135,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"
|
||||
-- "boolean" (to include all Boolean values in the string format "true"/"false"),
|
||||
-- "key" (to include all keys) or "all" (to include all above).
|
||||
-- These values can be combined together to include, e.g. all string and numeric values.
|
||||
jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)
|
||||
jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
|
||||
jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
|
||||
|
||||
-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
tsDelete :: FunctionN
|
||||
tsDelete ::
|
||||
'[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
|
||||
(null 'PGtsvector)
|
||||
---> null 'PGtsvector
|
||||
tsDelete = unsafeFunctionN "ts_delete"
|
||||
|
||||
-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
|
||||
tsFilter :: FunctionN
|
||||
tsFilter ::
|
||||
'[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
|
||||
(null 'PGtsvector)
|
||||
---> null 'PGtsvector
|
||||
tsFilter = unsafeFunctionN "ts_filter"
|
||||
|
||||
-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
|
||||
tsHeadline
|
||||
:: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
|
||||
=> FunctionN '[null document, null 'PGtsquery] (null 'PGtext)
|
||||
=> '[null document, null 'PGtsquery] ---> null 'PGtext
|
||||
tsHeadline = unsafeFunctionN "ts_headline"
|
||||
|
||||
@ -17,6 +17,7 @@ Date/Time functions and operators
|
||||
, OverloadedStrings
|
||||
, PolyKinds
|
||||
, RankNTypes
|
||||
, TypeOperators
|
||||
#-}
|
||||
|
||||
module Squeal.PostgreSQL.Expression.Time
|
||||
@ -85,9 +86,7 @@ Create date from year, month and day fields
|
||||
>>> printSQL (makeDate (1984 :* 7 *: 3))
|
||||
make_date(1984, 7, 3)
|
||||
-}
|
||||
makeDate :: FunctionN
|
||||
'[ null 'PGint4, null 'PGint4, null 'PGint4 ]
|
||||
( null 'PGdate )
|
||||
makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
|
||||
makeDate = unsafeFunctionN "make_date"
|
||||
|
||||
{-|
|
||||
@ -96,9 +95,7 @@ Create time from hour, minute and seconds fields
|
||||
>>> printSQL (makeTime (8 :* 15 *: 23.5))
|
||||
make_time(8, 15, 23.5)
|
||||
-}
|
||||
makeTime :: FunctionN
|
||||
'[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]
|
||||
( null 'PGtime )
|
||||
makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
|
||||
makeTime = unsafeFunctionN "make_time"
|
||||
|
||||
{-|
|
||||
@ -107,10 +104,9 @@ Create timestamp from year, month, day, hour, minute and seconds fields
|
||||
>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
|
||||
make_timestamp(2013, 7, 15, 8, 15, 23.5)
|
||||
-}
|
||||
makeTimestamp :: FunctionN
|
||||
makeTimestamp ::
|
||||
'[ null 'PGint4, null 'PGint4, null 'PGint4
|
||||
, null 'PGint4, null 'PGint4, null 'PGfloat8 ]
|
||||
( null 'PGtimestamp )
|
||||
, null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
|
||||
makeTimestamp = unsafeFunctionN "make_timestamp"
|
||||
|
||||
{-|
|
||||
@ -121,10 +117,9 @@ the current time zone is used
|
||||
>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
|
||||
make_timestamptz(2013, 7, 15, 8, 15, 23.5)
|
||||
-}
|
||||
makeTimestamptz :: FunctionN
|
||||
makeTimestamptz ::
|
||||
'[ null 'PGint4, null 'PGint4, null 'PGint4
|
||||
, null 'PGint4, null 'PGint4, null 'PGfloat8 ]
|
||||
( null 'PGtimestamptz )
|
||||
, null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
|
||||
makeTimestamptz = unsafeFunctionN "make_timestamptz"
|
||||
|
||||
{-|
|
||||
|
||||
@ -31,6 +31,7 @@ module Squeal.PostgreSQL.Expression.Type
|
||||
, astype
|
||||
, inferredtype
|
||||
, PGTyped (..)
|
||||
, FieldTyped (..)
|
||||
, typedef
|
||||
, typetable
|
||||
, typeview
|
||||
@ -339,3 +340,10 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)
|
||||
instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
|
||||
instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
|
||||
instance PGTyped schemas (null 'PGoid) where pgtype = oid
|
||||
|
||||
-- | Lift `PGTyped` to a field
|
||||
class FieldTyped schemas ty where
|
||||
fieldtype :: Aliased (TypeExpression schemas) ty
|
||||
instance (KnownSymbol alias, PGTyped schemas ty)
|
||||
=> FieldTyped schemas (alias ::: ty) where
|
||||
fieldtype = pgtype `As` Alias
|
||||
|
||||
@ -167,6 +167,9 @@ import qualified GHC.Generics as GHC
|
||||
import Squeal.PostgreSQL.Alias
|
||||
import Squeal.PostgreSQL.Binary
|
||||
import Squeal.PostgreSQL.Definition
|
||||
import Squeal.PostgreSQL.Definition.Table
|
||||
import Squeal.PostgreSQL.Definition.Table.Column
|
||||
import Squeal.PostgreSQL.Definition.Table.Constraint
|
||||
import Squeal.PostgreSQL.Expression.Comparison
|
||||
import Squeal.PostgreSQL.Expression.Parameter
|
||||
import Squeal.PostgreSQL.Expression.Time
|
||||
|
||||
@ -44,6 +44,8 @@ module Squeal.PostgreSQL.Schema
|
||||
, ColumnsType
|
||||
, TableType
|
||||
, SchemumType (..)
|
||||
, IndexType (..)
|
||||
, FunctionType
|
||||
, OperatorType (..)
|
||||
, ReturnsType (..)
|
||||
, SchemaType
|
||||
@ -60,7 +62,12 @@ module Squeal.PostgreSQL.Schema
|
||||
, PGlabel (..)
|
||||
-- * Data Definitions
|
||||
, Create
|
||||
, CreateIfNotExists
|
||||
, CreateOrReplace
|
||||
, Drop
|
||||
, DropSchemum
|
||||
, DropIfExists
|
||||
, DropSchemumIfExists
|
||||
, Alter
|
||||
, Rename
|
||||
, ConstraintInvolves
|
||||
@ -322,16 +329,69 @@ type family Create alias x xs where
|
||||
Create alias x (alias ::: y ': xs) = TypeError
|
||||
('Text "Create: alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text "already in use")
|
||||
':<>: 'Text "already exists")
|
||||
Create alias y (x ': xs) = x ': Create alias y xs
|
||||
|
||||
type family CreateIfNotExists alias x xs where
|
||||
CreateIfNotExists alias x '[] = '[alias ::: x]
|
||||
CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
|
||||
CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
|
||||
|
||||
type family CreateOrReplace alias x xs where
|
||||
CreateOrReplace alias x '[] = '[alias ::: x]
|
||||
CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
|
||||
CreateOrReplace alias x (alias ::: y ': xs) = TypeError
|
||||
('Text "CreateOrReplace: expected type "
|
||||
':<>: 'ShowType x
|
||||
':<>: 'Text " but alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text " has type "
|
||||
':<>: 'ShowType y)
|
||||
CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace 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 '[] = TypeError
|
||||
('Text "Drop: alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text " does not exist" )
|
||||
Drop alias (alias ::: x ': xs) = xs
|
||||
Drop alias (x ': xs) = x ': Drop alias xs
|
||||
|
||||
type family DropSchemum alias sch xs where
|
||||
DropSchemum alias sch '[] = TypeError
|
||||
('Text "DropSchemum: alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text " does not exist" )
|
||||
DropSchemum alias sch (alias ::: sch x ': xs) = xs
|
||||
DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
|
||||
('Text "DropSchemum: expected schemum "
|
||||
':<>: 'ShowType sch0
|
||||
':<>: 'Text " but alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text " has schemum "
|
||||
':<>: 'ShowType sch1)
|
||||
DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
|
||||
|
||||
type family DropIfExists alias xs where
|
||||
DropIfExists alias '[] = '[]
|
||||
DropIfExists alias (alias ::: x ': xs) = xs
|
||||
DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
|
||||
|
||||
type family DropSchemumIfExists alias sch xs where
|
||||
DropSchemumIfExists alias sch '[] = '[]
|
||||
DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
|
||||
DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
|
||||
('Text "DropSchemumIfExists: expected schemum "
|
||||
':<>: 'ShowType sch1
|
||||
':<>: 'Text " but alias "
|
||||
':<>: 'ShowType alias
|
||||
':<>: 'Text " has schemum "
|
||||
':<>: 'ShowType sch0)
|
||||
DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
|
||||
|
||||
-- | @Alter alias x xs@ 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`.
|
||||
@ -368,11 +428,21 @@ data SchemumType
|
||||
= Table TableType
|
||||
| View RowType
|
||||
| Typedef PGType
|
||||
| Index
|
||||
| Function [NullityType] ReturnsType
|
||||
| Index IndexType
|
||||
| Function FunctionType
|
||||
| Operator OperatorType
|
||||
| UnsafeSchemum Symbol
|
||||
|
||||
type FunctionType = ([NullityType], ReturnsType)
|
||||
|
||||
data IndexType
|
||||
= Btree
|
||||
| Hash
|
||||
| Gist
|
||||
| Spgist
|
||||
| Gin
|
||||
| Brin
|
||||
|
||||
data ReturnsType
|
||||
= Returns NullityType
|
||||
| ReturnsTable RowType
|
||||
|
||||
Loading…
Reference in New Issue
Block a user