@@ -10,7 +10,6 @@ tables, schema, constraints, aliases, enumerated labels, and groupings.
10It also defines useful type families to operate on these. Finally,
10It also defines useful type families to operate on these. Finally,
11it defines an embedding of Haskell types into Postgres types.
11it defines an embedding of Haskell types into Postgres types.
13−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
14{-# LANGUAGE
13{-# LANGUAGE
15 AllowAmbiguousTypes
14 AllowAmbiguousTypes
16 , ConstraintKinds
15 , ConstraintKinds
@@ -54,33 +53,9 @@ module Squeal.PostgreSQL.Schema
54 , TableConstraint (..)
53 , TableConstraint (..)
55 , TableConstraints
54 , TableConstraints
56 , Uniquely
55 , Uniquely
67− , QualifiedAlias (..)
72− , DefaultAliasable (..)
73 -- * Enumerated Labels
56 -- * Enumerated Labels
74 , IsPGlabel (..)
57 , IsPGlabel (..)
75 , PGlabel (..)
58 , PGlabel (..)
84 -- * Data Definitions
59 -- * Data Definitions
@@ -88,14 +63,8 @@ module Squeal.PostgreSQL.Schema
89 , ConstraintInvolves
64 , ConstraintInvolves
90 , DropIfConstraintsInvolve
65 , DropIfConstraintsInvolve
91− -- * Lists
66+ , IsNotElem
92− , Join
67+ , AllUnique
99 -- * Type Classifications
68 -- * Type Classifications
100 , HasOid (..)
69 , HasOid (..)
@@ -118,20 +87,15 @@ module Squeal.PostgreSQL.Schema
120import Control.Category
89import Control.Category
121−import Control.DeepSeq
122−import Data.ByteString (ByteString)
123import Data.Kind
90import Data.Kind
124import Data.Monoid hiding (All)
91import Data.Monoid hiding (All)
126import Data.Type.Bool
92import Data.Type.Bool
127import Data.Word (Word32)
93import Data.Word (Word32)
128import Generics.SOP
94import Generics.SOP
129−import GHC.OverloadedLabels
130import GHC.TypeLits
95import GHC.TypeLits
131import Prelude hiding (id, (.))
96import Prelude hiding (id, (.))
133−import qualified GHC.Generics as GHC
98+import Squeal.PostgreSQL.Alias
135import Squeal.PostgreSQL.Render
99import Squeal.PostgreSQL.Render
137-- | `PGType` is the promoted datakind of PostgreSQL types.
101-- | `PGType` is the promoted datakind of PostgreSQL types.
@@ -216,11 +180,6 @@ data NullityType
216type (:=>) constraint ty = '(constraint,ty)
180type (:=>) constraint ty = '(constraint,ty)
217infixr 7 :=>
181infixr 7 :=>
219−-- | The alias operator `:::` is like a promoted version of `As`,
220−-- a type level pair between an alias and some type.
221−type (:::) (alias :: Symbol) ty = '(alias,ty)
224-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
183-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
225-- A column can be assigned a default value.
184-- A column can be assigned a default value.
226-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
185-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
@@ -327,203 +286,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
327type family TableToRow (table :: TableType) :: RowType where
286type family TableToRow (table :: TableType) :: RowType where
328 TableToRow tab = ColumnsToRow (TableToColumns tab)
287 TableToRow tab = ColumnsToRow (TableToColumns tab)
330−-- | `Grouping` is an auxiliary namespace, created by
331−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
332−-- for typesafe aggregation
334− = Ungrouped -- ^ no aggregation permitted
335− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
337−{- | A `GroupedBy` constraint indicates that a table qualified column is
338−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
339−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
341−class (KnownSymbol table, KnownSymbol column)
342− => GroupedBy table column bys where
343−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
344− => GroupedBy table column ('(table,column) ': bys)
345−instance {-# OVERLAPPABLE #-}
347− , KnownSymbol column
348− , GroupedBy table column bys
349− ) => GroupedBy table column (tabcol ': bys)
351−-- | `Alias`es are proxies for a type level string or `Symbol`
352−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
354−-- >>> :set -XOverloadedLabels
355−-- >>> #foobar :: Alias "foobar"
357−data Alias (alias :: Symbol) = Alias
358− deriving (Eq,GHC.Generic,Ord,Show,NFData)
359−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
361−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
362− fromLabel = fromLabel :* Nil
363−-- | >>> printSQL (#jimbob :: Alias "jimbob")
365−instance KnownSymbol alias => RenderSQL (Alias alias) where
366− renderSQL = doubleQuoted . fromString . symbolVal
368−-- | >>> import Generics.SOP (NP(..))
369−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
371−instance All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
375− . hcmap (Proxy @KnownSymbol) (K . renderSQL)
377−-- | The `As` operator is used to name an expression. `As` is like a demoted
380−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
381−-- As (Just "hello") Alias
382−data Aliased expression aliased where
384− :: KnownSymbol alias
387− -> Aliased expression (alias ::: ty)
388−deriving instance Show (expression ty)
389− => Show (Aliased expression (alias ::: ty))
390−deriving instance Eq (expression ty)
391− => Eq (Aliased expression (alias ::: ty))
392−deriving instance Ord (expression ty)
393− => Ord (Aliased expression (alias ::: ty))
394−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
395− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
396− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
398−-- | The `Aliasable` class provides a way to scrap your `Nil`s
399−-- in an `NP` list of `Aliased` expressions.
400−class KnownSymbol alias => Aliasable alias expression aliased
401− | aliased -> expression
403− where as :: expression -> Alias alias -> aliased
404−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
406− (Aliased expression aliased)
409−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
411− (NP (Aliased expression) tys)
413− expression `as` alias = expression `As` alias :* Nil
415−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
416−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
417−-- "Just AS \"an_int\""
419− :: (forall ty. expression ty -> ByteString)
420− -> Aliased expression aliased
422−renderAliased render (expression `As` alias) =
423− render expression <> " AS " <> renderSQL alias
425−-- | @HasUnique alias fields field@ is a constraint that proves that
426−-- @fields@ is a singleton of @alias ::: field@.
427−type HasUnique alias fields field = fields ~ '[alias ::: field]
429−-- | @Has alias fields field@ is a constraint that proves that
430−-- @fields@ has a field of @alias ::: field@, inferring @field@
431−-- from @alias@ and @fields@.
432−class KnownSymbol alias =>
433− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
434− | alias fields -> field where
435−instance {-# OVERLAPPING #-} KnownSymbol alias
436− => Has alias (alias ::: field ': fields) field
437−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
438− => Has alias (field' ': fields) field
440−{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
441−@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
442−choose which subfields to update.
444−class HasIn fields field where
445−instance (Has alias fields field) => HasIn fields (alias ::: field) where
447−-- | Utility class for `AllUnique` to provide nicer error messages.
448−class IsNotElem x isElem where
449−instance IsNotElem x 'False where
450−instance (TypeError ( 'Text "Cannot assign to "
451− ':<>: 'ShowType alias
452− ':<>: 'Text " more than once"))
453− => IsNotElem '(alias, a) 'True where
455−-- | No elem of @xs@ appears more than once, in the context of assignment.
456−class AllUnique (xs :: [(Symbol, a)]) where
457−instance AllUnique '[] where
458−instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
461−The `DefaultAliasable` class is intended to help with Scrap your Nils
462−for default inserts and updates.
464−class KnownSymbol alias
465− => DefaultAliasable alias aliased | aliased -> alias where
466− defaultAs :: Alias alias -> aliased
468−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
469−-- a list of @subfields@.
471− ( All KnownSymbol aliases
473− (aliases :: [Symbol])
474− (fields :: [(Symbol,kind)])
475− (subfields :: [(Symbol,kind)])
476− | aliases fields -> subfields where
477−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
478−instance {-# OVERLAPPABLE #-}
479− (Has alias fields field, HasAll aliases fields subfields)
480− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
482−-- | Analagous to `IsLabel`, the constraint
483−-- `IsQualified` defines `!` for a column alias qualified
485−class IsQualified table column expression where
486− (!) :: Alias table -> Alias column -> expression
488−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
490−{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
491−to a `Table`, `Typedef` or `View` to be qualified by their schemas. By default,
492−a qualifier of @public@ is provided.
496− alias1 :: QualifiedAlias "sch" "tab"
497− alias1 = #sch ! #tab
498− alias2 :: QualifiedAlias "public" "vw"
500−in printSQL alias1 >> printSQL alias2
505−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
506− deriving (Eq,GHC.Generic,Ord,Show,NFData)
507−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
508− _!_ = QualifiedAlias
509−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
510− fromLabel = QualifiedAlias
511−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
512− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
513− _!_ = QualifiedAlias `As` Alias
514−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
515− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
516− fromLabel = QualifiedAlias `As` Alias
518−instance (KnownSymbol q, KnownSymbol a)
519− => RenderSQL (QualifiedAlias q a) where
522− qualifier = renderSQL (Alias @q)
523− alias = renderSQL (Alias @a)
525− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
527-- | @Elem@ is a promoted `Data.List.elem`.
289-- | @Elem@ is a promoted `Data.List.elem`.
528type family Elem x xs where
290type family Elem x xs where
529 Elem x '[] = 'False
291 Elem x '[] = 'False
@@ -584,22 +346,6 @@ type family NullifyFrom (tables :: FromType) :: FromType where
584 NullifyFrom (table ::: columns ': tables) =
346 NullifyFrom (table ::: columns ': tables) =
585 table ::: NullifyRow columns ': NullifyFrom tables
347 table ::: NullifyRow columns ': NullifyFrom tables
587−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
588−-- `Squeal.PostgreSQL.Query.FromClause`s.
589−type family Join xs ys where
591− Join (x ': xs) ys = x ': Join xs ys
593−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
595− :: forall xs ys expr. SListI xs
596− => NP expr (Join xs ys)
597− -> (NP expr xs, NP expr ys)
598−disjoin = case sList @xs of
599− SNil -> \ys -> (Nil, ys)
600− SCons -> \(x :* xsys) ->
601− case disjoin xsys of (xs,ys) -> (x :* xs, ys)
603-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
349-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
604-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
350-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
605-- `Squeal.PostgreSQL.Definition.addColumn`.
351-- `Squeal.PostgreSQL.Definition.addColumn`.
@@ -734,48 +480,15 @@ type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
734-- | Is a type a valid JSON type?
480-- | Is a type a valid JSON type?
735type PGJsonType = '[ 'PGjson, 'PGjsonb ]
481type PGJsonType = '[ 'PGjson, 'PGjsonb ]
737−-- | An `AlignedList` is a type-aligned list or free category.
483+-- | Utility class for `AllUnique` to provide nicer error messages.
738−data AlignedList p x0 x1 where
484+class IsNotElem x isElem where
739− Done :: AlignedList p x x
485+instance IsNotElem x 'False where
740− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
486+instance (TypeError ( 'Text "Cannot assign to "
741−infixr 7 :>>
487+ ':<>: 'ShowType alias
742−instance Category (AlignedList p) where
488+ ':<>: 'Text " more than once"))
743− id = Done
489+ => IsNotElem '(alias, a) 'True where
744− (.) list = \case
490+
745− Done -> list
491+-- | No elem of @xs@ appears more than once, in the context of assignment.
746− step :>> steps -> step :>> (steps >>> list)
492+class AllUnique (xs :: [(Symbol, a)]) where
747−instance (forall t0 t1. RenderSQL (p t0 t1))
493+instance AllUnique '[] where
748− => RenderSQL (AlignedList p x0 x1) where
494+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
751− step :>> Done -> renderSQL step
752− step :>> steps -> renderSQL step <> ", " <> renderSQL steps
754−extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
755−extractList f = \case
757− step :>> steps -> (f step):extractList f steps
760− :: (forall z0 z1. p z0 z1 -> q z0 z1)
761− -> AlignedList p x0 x1
762− -> AlignedList q x0 x1
765− x :>> xs -> f x :>> alignedMap f xs
767−-- | A `single` step.
768−single :: p x0 x1 -> AlignedList p x0 x1
769−single step = step :>> Done
771−-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
772−(*:) :: f x -> f y -> NP f '[x,y]
773−x *: y = x :* y :* Nil
776−-- | Concatenate `NP` lists.
777−(+++) :: NP f xs -> NP f ys -> NP f (Join xs ys)
778−xs +++ ys = case xs of
780− x :* xs' -> x :* (xs' +++ ys)