@@ -40,6 +40,9 @@ module Squeal.PostgreSQL.Schema
4040 , NilRelation
4141 , RelationsType
4242 , TableType
43+ -- * Schema
44+ , SchemumType (..)
45+ , SchemaType
4346 -- * Grouping
4447 , Grouping (..)
4548 , GroupedBy
@@ -66,6 +69,7 @@ module Squeal.PostgreSQL.Schema
6669 , IsQualified (..)
6770 -- * Type Families
6871 , Join
72+ , With
6973 , Create
7074 , Drop
7175 , Alter
@@ -84,32 +88,27 @@ module Squeal.PostgreSQL.Schema
8488 , NullifyRelation
8589 , NullifyRelations
8690 , ColumnsToRelation
87− , RelationToColumns
8891 , TableToColumns
92+ , TableToRelation
8993 , ConstraintInvolves
9094 , DropIfConstraintsInvolve
9195 -- * Generics
92− , SameField
93− , SameFields
94− , SameLabel
95− , SameLabels
9696 , MapMaybes (..)
9797 , Nulls
98+ -- * Enum Labels
9899 , IsPGlabel (..)
99100 , PGlabel (..)
100101 , renderLabel
101102 , renderLabels
102103 , LabelOf
103104 , LabelsOf
104− , DatatypeLabels
105− -- * Schema
106− , SchemumType (..)
107− , SchemaType
108− , With
109− -- * STUFF
105+ -- * Embedding
110106 , PG
111− , PGenumWith
112− , PGcompositeWith
107+ , EnumWith
108+ , LabelsWith
109+ , CompositeWith
110+ , FieldNamesWith
111+ , FieldTypesWith
113112 , ConstructorsOf
114113 , ConstructorNameOf
115114 , ConstructorNamesOf
@@ -118,28 +117,30 @@ module Squeal.PostgreSQL.Schema
118117 , FieldNamesOf
119118 , FieldTypeOf
120119 , FieldTypesOf
121− , RecordFieldTypesOf
120+ , RecordCodeOf
122121 ) where
123122
124123import Control.DeepSeq
125124import Data.Aeson (Value)
126125import Data.ByteString (ByteString)
127−import Data.Int
126+import Data.Int (Int16, Int32, Int64)
128127import Data.Kind
129128import Data.Monoid hiding (All)
130−import Data.Scientific
129+import Data.Scientific (Scientific)
131130import Data.String
132131import Data.Text (Text)
133132import Data.Time
134−import Data.Word
133+import Data.Word (Word16, Word32, Word64)
135134import Data.Type.Bool
136135import Data.UUID.Types (UUID)
136+import Generics.SOP
137137import GHC.OverloadedLabels
138138import GHC.TypeLits
139139import Network.IP.Addr
140140
141+import qualified Data.ByteString.Lazy as Lazy
142+import qualified Data.Text.Lazy as Lazy
141143import qualified GHC.Generics as GHC
142−import qualified Generics.SOP as SOP
143144import qualified Generics.SOP.Type.Metadata as Type
144145
145146import Squeal.PostgreSQL.Render
@@ -323,16 +324,13 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
323324 ColumnsToRelation (column ::: constraint :=> ty ': columns) =
324325 column ::: ty ': ColumnsToRelation columns
325326
326−-- | `RelationToColumns` adds `'NoDef` column constraints.
327−type family RelationToColumns (relation :: RelationType) :: ColumnsType where
328− RelationToColumns '[] = '[]
329− RelationToColumns (column ::: ty ': columns) =
330− column ::: 'NoDef :=> ty ': RelationToColumns columns
331−
332327-- | `TableToColumns` removes table constraints.
333328type family TableToColumns (table :: TableType) :: ColumnsType where
334329 TableToColumns (constraints :=> columns) = columns
335330
331+type family TableToRelation (table :: TableType) :: RelationType where
332+ TableToRelation tab = ColumnsToRelation (TableToColumns tab)
333+
336334-- | `Grouping` is an auxiliary namespace, created by
337335-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
338336-- for typesafe aggregation
@@ -364,8 +362,8 @@ data Alias (alias :: Symbol) = Alias
364362 deriving (Eq,GHC.Generic,Ord,Show,NFData)
365363instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
366364 fromLabel = Alias
367−instance aliases ~ '[alias] => IsLabel alias (SOP.NP Alias aliases) where
368− fromLabel = fromLabel SOP.:* SOP.Nil
365+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
366+ fromLabel = fromLabel :* Nil
369367
370368-- | >>> renderAlias #jimbob
371369-- "\"jimbob\""
@@ -376,9 +374,9 @@ renderAlias = doubleQuoted . fromString . symbolVal
376374-- >>> renderAliases (#jimbob :* #kandi :* Nil)
377375-- ["\"jimbob\"","\"kandi\""]
378376renderAliases
379− :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString]
380−renderAliases = SOP.hcollapse
381− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias)
377+ :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]
378+renderAliases = hcollapse
379+ . hcmap (Proxy @KnownSymbol) (K . renderAlias)
382380
383381-- | The `As` operator is used to name an expression. `As` is like a demoted
384382-- version of `:::`.
@@ -413,26 +411,29 @@ type family AliasesOf aliaseds where
413411 AliasesOf '[] = '[]
414412 AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
415413
416−class SOP.All KnownSymbol ns => ZipAliased ns xs where
414+class
415+ ( SListI (ZipAs ns xs)
416+ , All KnownSymbol ns
417+ ) => ZipAliased ns xs where
417418
418419 type family ZipAs
419420 (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs
420421
421− zipAliases
422− :: SOP.NP Alias ns
423− -> SOP.NP expr xs
424− -> SOP.NP (Aliased expr) (ZipAs ns xs)
422+ zipAs
423+ :: NP Alias ns
424+ -> NP expr xs
425+ -> NP (Aliased expr) (ZipAs ns xs)
425426
426427instance ZipAliased '[] '[] where
427428 type ZipAs '[] '[] = '[]
428− zipAliases SOP.Nil SOP.Nil = SOP.Nil
429+ zipAs Nil Nil = Nil
429430
430431instance
431432 ( KnownSymbol n
432433 , ZipAliased ns xs
433434 ) => ZipAliased (n ': ns) (x ': xs) where
434435 type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs
435− zipAliases (n SOP.:* ns) (x SOP.:* xs) = x `As` n SOP.:* zipAliases ns xs
436+ zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs
436437
437438-- | @HasUnique alias fields field@ is a constraint that proves that
438439-- @fields@ is a singleton of @alias ::: field@.
@@ -449,7 +450,7 @@ instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
449450 => Has alias (field' ': fields) field
450451
451452class
452− ( SOP.All KnownSymbol aliases
453+ ( All KnownSymbol aliases
453454 ) => HasAll
454455 (aliases :: [Symbol])
455456 (fields :: [(Symbol,kind)])
@@ -592,50 +593,18 @@ type family Rename alias0 alias1 xs where
592593 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
593594 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
594595
595−-- | A `SameField` constraint is an equality constraint on a
596−-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.
597−class SameField
598− (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where
599−instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
600−
601−-- | A `SameFields` constraint proves that a
602−-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same
603−-- field names as the column AliasesOf of a `ColumnsType`.
604−type family SameFields
605− (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ty)])
606− :: Constraint where
607− SameFields
608− ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
609− columns
610− = SOP.AllZip SameField fields columns
611− SameFields
612− ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
613− columns
614− = SOP.AllZip SameField fields columns
615−
616−class SameLabel
617− (constrInfo :: Type.ConstructorInfo) (label :: Symbol) where
618−instance name ~ label => SameLabel ('Type.Constructor name) label
619−
620−type family SameLabels
621− (datatypeInfo :: Type.DatatypeInfo) (labels :: [Symbol])
622− :: Constraint where
623− SameLabels
624− ('Type.ADT _module _datatype constructors) labels
625− = SOP.AllZip SameLabel constructors labels
626−
627596class MapMaybes xs where
628597 type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs
629− maybes :: SOP.NP Maybe xs -> SOP.NP SOP.I (Maybes xs)
630− unMaybes :: SOP.NP SOP.I (Maybes xs) -> SOP.NP Maybe xs
598+ maybes :: NP Maybe xs -> NP I (Maybes xs)
599+ unMaybes :: NP I (Maybes xs) -> NP Maybe xs
631600instance MapMaybes '[] where
632601 type Maybes '[] = '[]
633− maybes SOP.Nil = SOP.Nil
634− unMaybes SOP.Nil = SOP.Nil
602+ maybes Nil = Nil
603+ unMaybes Nil = Nil
635604instance MapMaybes xs => MapMaybes (x ': xs) where
636605 type Maybes (x ': xs) = Maybe x ': Maybes xs
637− maybes (x SOP.:* xs) = SOP.I x SOP.:* maybes xs
638− unMaybes (SOP.I mx SOP.:* xs) = mx SOP.:* unMaybes xs
606+ maybes (x :* xs) = I x :* maybes xs
607+ unMaybes (I mx :* xs) = mx :* unMaybes xs
639608
640609type family Nulls tys where
641610 Nulls '[] = '[]
@@ -679,12 +648,12 @@ data PGlabel (label :: Symbol) = PGlabel
679648
680649renderLabel :: KnownSymbol label => proxy label -> ByteString
681650renderLabel (_ :: proxy label) =
682− "\'" <> fromString (symbolVal (SOP.Proxy @label)) <> "\'"
651+ "\'" <> fromString (symbolVal (Proxy @label)) <> "\'"
683652
684653renderLabels
685− :: SOP.All KnownSymbol labels => SOP.NP PGlabel labels -> [ByteString]
686−renderLabels = SOP.hcollapse
687− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderLabel)
654+ :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]
655+renderLabels = hcollapse
656+ . hcmap (Proxy @KnownSymbol) (K . renderLabel)
688657
689658type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where
690659 LabelOf ('Type.Constructor name) = name
@@ -693,19 +662,22 @@ type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where
693662 LabelsOf '[] = '[]
694663 LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss
695664
696−type family DatatypeLabels (info :: Type.DatatypeInfo) :: [Symbol] where
697− DatatypeLabels ('Type.ADT _module _datatype constructors) = LabelsOf constructors
698−
699−type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where
665+type family PG (hask :: Type) :: PGType where
700666 PG Bool = 'PGbool
701667 PG Int16 = 'PGint2
702668 PG Int32 = 'PGint4
703669 PG Int64 = 'PGint8
670+ PG Word16 = 'PGint2
671+ PG Word32 = 'PGint4
672+ PG Word64 = 'PGint8
704673 PG Scientific = 'PGnumeric
705674 PG Float = 'PGfloat4
706675 PG Double = 'PGfloat8
676+ PG Char = 'PGchar 1
707677 PG Text = 'PGtext
678+ PG Lazy.Text = 'PGtext
708679 PG ByteString = 'PGbytea
680+ PG Lazy.ByteString = 'PGbytea
709681 PG LocalTime = 'PGtimestamp
710682 PG UTCTime = 'PGtimestamptz
711683 PG Day = 'PGdate
@@ -715,16 +687,25 @@ type family PG (hask :: Type) = (pg :: PGType) | pg -> hask where
715687 PG UUID = 'PGuuid
716688 PG (NetAddr IP) = 'PGinet
717689 PG Value = 'PGjson
690+ PG ty = TypeError
691+ ('Text "There is no basic Postgres type for " ':<>: 'ShowType ty)
718692
719−type family PGenumWith (hask :: Type) :: [Type.ConstructorName] where
720− PGenumWith hask =
721− ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
693+type family EnumWith (hask :: Type) :: PGType where
694+ EnumWith hask = 'PGenum (LabelsWith hask)
722695
723−type family PGcompositeWith (hask :: Type) :: PGType where
724− PGcompositeWith hask =
725− 'PGcomposite (ZipAs
726− (FieldNamesOf (FieldsOf (SOP.DatatypeInfoOf hask)))
727− (RecordFieldTypesOf (SOP.Code hask)))
696+type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where
697+ LabelsWith hask =
698+ ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
699+
700+type family CompositeWith (hask :: Type) :: PGType where
701+ CompositeWith hask =
702+ 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask))
703+
704+type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where
705+ FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))
706+
707+type family FieldTypesWith (hask :: Type) :: [PGType] where
708+ FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask))
728709
729710type family ConstructorsOf (datatype :: Type.DatatypeInfo)
730711 :: [Type.ConstructorInfo] where
@@ -736,8 +717,12 @@ type family ConstructorsOf (datatype :: Type.DatatypeInfo)
736717type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
737718 :: Type.ConstructorName where
738719 ConstructorNameOf ('Type.Constructor name) = name
739− ConstructorNameOf ('Type.Infix name _assoc _fix) = name
740− ConstructorNameOf ('Type.Record name _fields) = name
720+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
721+ ('Text "ConstructorNameOf error: non-nullary constructor "
722+ ':<>: 'Text name)
723+ ConstructorNameOf ('Type.Record name _fields) = TypeError
724+ ('Text "ConstructorNameOf error: non-nullary constructor "
725+ ':<>: 'Text name)
741726
742727type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
743728 :: [Type.ConstructorName] where
@@ -749,6 +734,8 @@ type family FieldsOf (constructor :: Type.DatatypeInfo)
749734 :: [Type.FieldInfo] where
750735 FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =
751736 fields
737+ FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =
738+ fields
752739
753740type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where
754741 FieldNameOf ('Type.FieldInfo name) = name
@@ -760,10 +747,14 @@ type family FieldNamesOf (fields :: [Type.FieldInfo])
760747
761748type family FieldTypeOf (maybe :: Type) where
762749 FieldTypeOf (Maybe hask) = PG hask
750+ FieldTypeOf ty = TypeError
751+ ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)
763752
764753type family FieldTypesOf (fields :: [Type]) where
765754 FieldTypesOf '[] = '[]
766755 FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields
767756
768−type family RecordFieldTypesOf (code :: [[Type]]) where
769− RecordFieldTypesOf '[fields] = FieldTypesOf fields
757+type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where
758+ RecordCodeOf _hask '[tys] = tys
759+ RecordCodeOf hask _tys = TypeError
760+ ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)