git.iko.soy/squeal
on dev help sign in
0.5

* Tutorial module * Alias module * List module * PG module

commit212174e63d7567a14549009ac50f9d0a9153c953 authorEitan Chatav <eitan@Eitans-MacBook-Pro.local> dateSat 6 Apr 2019, 08:52 (8 years ago) parentb7781f4
13 files changed+766−506
compare with dev
unifiedsplit
squeal-postgresql/squeal-postgresql.cabal+3 squeal-postgresql/src/Squeal/PostgreSQL.hs+7−1 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs+242 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+8−181 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+2 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+3 squeal-postgresql/src/Squeal/PostgreSQL/List.hs+123 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+3−1 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+21−20 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+297 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+3−1 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+15−302 squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hs+39
squeal-postgresql/squeal-postgresql.cabal+3
@@ -22,12 +22,15 @@ library
2222 hs-source-dirs: src
2323 exposed-modules:
2424 Squeal.PostgreSQL
25+ Squeal.PostgreSQL.Alias
2526 Squeal.PostgreSQL.Binary
2627 Squeal.PostgreSQL.Definition
2728 Squeal.PostgreSQL.Expression
29+ Squeal.PostgreSQL.List
2830 Squeal.PostgreSQL.Manipulation
2931 Squeal.PostgreSQL.Migration
3032 Squeal.PostgreSQL.Pool
33+ Squeal.PostgreSQL.PG
3134 Squeal.PostgreSQL.PQ
3235 Squeal.PostgreSQL.Render
3336 Squeal.PostgreSQL.Query
squeal-postgresql/src/Squeal/PostgreSQL.hs+7−1
@@ -194,20 +194,26 @@ in
194194[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
195195-}
196196module Squeal.PostgreSQL
197− ( module Squeal.PostgreSQL.Binary
197+ ( module Squeal.PostgreSQL.Alias
198+ , module Squeal.PostgreSQL.Binary
198199 , module Squeal.PostgreSQL.Definition
199200 , module Squeal.PostgreSQL.Expression
201+ , module Squeal.PostgreSQL.List
200202 , module Squeal.PostgreSQL.Manipulation
203+ , module Squeal.PostgreSQL.PG
201204 , module Squeal.PostgreSQL.PQ
202205 , module Squeal.PostgreSQL.Query
203206 , module Squeal.PostgreSQL.Schema
204207 , module Squeal.PostgreSQL.Transaction
205208 ) where
206209
210+import Squeal.PostgreSQL.Alias
207211import Squeal.PostgreSQL.Binary
208212import Squeal.PostgreSQL.Definition
209213import Squeal.PostgreSQL.Expression
214+import Squeal.PostgreSQL.List
210215import Squeal.PostgreSQL.Manipulation
216+import Squeal.PostgreSQL.PG
211217import Squeal.PostgreSQL.PQ
212218import Squeal.PostgreSQL.Query
213219import Squeal.PostgreSQL.Schema
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsnew file+242
@@ -0,0 +1,242 @@
1+{-# LANGUAGE
2+ AllowAmbiguousTypes
3+ , ConstraintKinds
4+ , DeriveAnyClass
5+ , DeriveGeneric
6+ , FlexibleContexts
7+ , FlexibleInstances
8+ , FunctionalDependencies
9+ , GADTs
10+ , LambdaCase
11+ , OverloadedStrings
12+ , QuantifiedConstraints
13+ , RankNTypes
14+ , ScopedTypeVariables
15+ , StandaloneDeriving
16+ , TypeApplications
17+ , TypeFamilyDependencies
18+ , TypeInType
19+ , TypeOperators
20+ , UndecidableInstances
21+ , UndecidableSuperClasses
22+#-}
23+
24+module Squeal.PostgreSQL.Alias
25+ ( (:::)
26+ , Alias (..)
27+ , IsLabel (..)
28+ , Aliased (As)
29+ , Aliasable (as)
30+ , renderAliased
31+ , Has
32+ , HasUnique
33+ , HasAll
34+ , HasIn
35+ , QualifiedAlias (..)
36+ , IsQualified (..)
37+ , DefaultAliasable (..)
38+ -- * Grouping
39+ , Grouping (..)
40+ , GroupedBy
41+ ) where
42+
43+import Control.DeepSeq
44+import Data.ByteString (ByteString)
45+import Data.String (fromString)
46+import GHC.OverloadedLabels
47+import GHC.TypeLits
48+
49+import qualified Generics.SOP as SOP
50+import qualified GHC.Generics as GHC
51+
52+import Squeal.PostgreSQL.Render
53+
54+-- | The alias operator `:::` is like a promoted version of `As`,
55+-- a type level pair between an alias and some type.
56+type (:::) (alias :: Symbol) ty = '(alias,ty)
57+infixr 6 :::
58+
59+
60+-- | `Grouping` is an auxiliary namespace, created by
61+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
62+-- for typesafe aggregation
63+data Grouping
64+ = Ungrouped -- ^ no aggregation permitted
65+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
66+
67+{- | A `GroupedBy` constraint indicates that a table qualified column is
68+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
69+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
70+-}
71+class (KnownSymbol table, KnownSymbol column)
72+ => GroupedBy table column bys where
73+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
74+ => GroupedBy table column ('(table,column) ': bys)
75+instance {-# OVERLAPPABLE #-}
76+ ( KnownSymbol table
77+ , KnownSymbol column
78+ , GroupedBy table column bys
79+ ) => GroupedBy table column (tabcol ': bys)
80+
81+-- | `Alias`es are proxies for a type level string or `Symbol`
82+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
83+--
84+-- >>> :set -XOverloadedLabels
85+-- >>> #foobar :: Alias "foobar"
86+-- Alias
87+data Alias (alias :: Symbol) = Alias
88+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
89+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
90+ fromLabel = Alias
91+instance aliases ~ '[alias] => IsLabel alias (SOP.NP Alias aliases) where
92+ fromLabel = fromLabel SOP.:* SOP.Nil
93+-- | >>> printSQL (#jimbob :: Alias "jimbob")
94+-- "jimbob"
95+instance KnownSymbol alias => RenderSQL (Alias alias) where
96+ renderSQL = doubleQuoted . fromString . symbolVal
97+
98+-- | >>> import Generics.SOP (SOP.NP(..))
99+-- >>> printSQL (#jimbob SOP.:* #kandi :: SOP.NP Alias '["jimbob", "kandi"])
100+-- "jimbob", "kandi"
101+instance SOP.All KnownSymbol aliases => RenderSQL (SOP.NP Alias aliases) where
102+ renderSQL
103+ = commaSeparated
104+ . SOP.hcollapse
105+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
106+
107+-- | The `As` operator is used to name an expression. `As` is like a demoted
108+-- version of `:::`.
109+--
110+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
111+-- As (Just "hello") Alias
112+data Aliased expression aliased where
113+ As
114+ :: KnownSymbol alias
115+ => expression ty
116+ -> Alias alias
117+ -> Aliased expression (alias ::: ty)
118+deriving instance Show (expression ty)
119+ => Show (Aliased expression (alias ::: ty))
120+deriving instance Eq (expression ty)
121+ => Eq (Aliased expression (alias ::: ty))
122+deriving instance Ord (expression ty)
123+ => Ord (Aliased expression (alias ::: ty))
124+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
125+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
126+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1
127+
128+-- | The `Aliasable` class provides a way to scrap your `SOP.Nil`s
129+-- in an `SOP.NP` list of `Aliased` expressions.
130+class KnownSymbol alias => Aliasable alias expression aliased
131+ | aliased -> expression
132+ , aliased -> alias
133+ where as :: expression -> Alias alias -> aliased
134+instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
135+ (expression ty)
136+ (Aliased expression aliased)
137+ where
138+ as = As
139+instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
140+ (expression ty)
141+ (SOP.NP (Aliased expression) tys)
142+ where
143+ expression `as` alias = expression `As` alias SOP.:* SOP.Nil
144+
145+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
146+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
147+-- "Just AS \"an_int\""
148+renderAliased
149+ :: (forall ty. expression ty -> ByteString)
150+ -> Aliased expression aliased
151+ -> ByteString
152+renderAliased render (expression `As` alias) =
153+ render expression <> " AS " <> renderSQL alias
154+
155+-- | @HasUnique alias fields field@ is a constraint that proves that
156+-- @fields@ is a singleton of @alias ::: field@.
157+type HasUnique alias fields field = fields ~ '[alias ::: field]
158+
159+-- | @Has alias fields field@ is a constraint that proves that
160+-- @fields@ has a field of @alias ::: field@, inferring @field@
161+-- from @alias@ and @fields@.
162+class KnownSymbol alias =>
163+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
164+ | alias fields -> field where
165+instance {-# OVERLAPPING #-} KnownSymbol alias
166+ => Has alias (alias ::: field ': fields) field
167+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
168+ => Has alias (field' ': fields) field
169+
170+{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
171+@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
172+choose which subfields to update.
173+-}
174+class HasIn fields field where
175+instance (Has alias fields field) => HasIn fields (alias ::: field) where
176+
177+{- |
178+The `DefaultAliasable` class is intended to help with Scrap your SOP.Nils
179+for default inserts and updates.
180+-}
181+class KnownSymbol alias
182+ => DefaultAliasable alias aliased | aliased -> alias where
183+ defaultAs :: Alias alias -> aliased
184+
185+-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
186+-- a list of @subfields@.
187+class
188+ ( SOP.All KnownSymbol aliases
189+ ) => HasAll
190+ (aliases :: [Symbol])
191+ (fields :: [(Symbol,kind)])
192+ (subfields :: [(Symbol,kind)])
193+ | aliases fields -> subfields where
194+instance {-# OVERLAPPING #-} HasAll '[] fields '[]
195+instance {-# OVERLAPPABLE #-}
196+ (Has alias fields field, HasAll aliases fields subfields)
197+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
198+
199+-- | Analagous to `IsLabel`, the constraint
200+-- `IsQualified` defines `!` for a column alias qualified
201+-- by a table alias.
202+class IsQualified table column expression where
203+ (!) :: Alias table -> Alias column -> expression
204+ infixl 9 !
205+instance IsQualified table column (Alias table, Alias column) where (!) = (,)
206+
207+{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
208+to a `Table`, `Typedef` or `View` to be qualified by their schemas. By default,
209+a qualifier of @public@ is provided.
210+
211+>>> :{
212+let
213+ alias1 :: QualifiedAlias "sch" "tab"
214+ alias1 = #sch ! #tab
215+ alias2 :: QualifiedAlias "public" "vw"
216+ alias2 = #vw
217+in printSQL alias1 >> printSQL alias2
218+:}
219+"sch"."tab"
220+"vw"
221+-}
222+data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
223+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
224+instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
225+ _!_ = QualifiedAlias
226+instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
227+ fromLabel = QualifiedAlias
228+instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
229+ IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
230+ _!_ = QualifiedAlias `As` Alias
231+instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
232+ IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
233+ fromLabel = QualifiedAlias `As` Alias
234+
235+instance (KnownSymbol q, KnownSymbol a)
236+ => RenderSQL (QualifiedAlias q a) where
237+ renderSQL _ =
238+ let
239+ qualifier = renderSQL (Alias @q)
240+ alias = renderSQL (Alias @a)
241+ in
242+ if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+8−181
@@ -202,14 +202,8 @@ True
202202#-}
203203
204204module Squeal.PostgreSQL.Binary
205− ( -- * PG type families
206− PG
207− , NullPG
208− , TuplePG
209− , RowPG
210− , LabelsPG
211− -- * Storage newtypes
212− , Money (..)
205+ ( -- * Storage newtypes
206+ Money (..)
213207 , Json (..)
214208 , Jsonb (..)
215209 , Composite (..)
@@ -219,24 +213,23 @@ module Squeal.PostgreSQL.Binary
219213 -- * Encoding
220214 , ToParam (..)
221215 , ToParams (..)
216+ , ToNullityParam
217+ , ToField
218+ , ToFixArray
222219 -- * Decoding
223220 , FromValue (..)
224221 , FromRow (..)
225222 -- * Only
226223 , Only (..)
227− , P (..)
228224 ) where
229225
230226import BinaryParser
231227import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
232228import Control.Arrow (left)
233229import Control.Monad
234−import Data.Aeson (Value)
235−import Data.ByteString (ByteString)
236230import Data.Int
237231import Data.Kind
238232import Data.Scientific
239−import Data.Text (Text)
240233import Data.Time
241234import Data.UUID.Types
242235import Data.Vector (Vector)
@@ -254,11 +247,13 @@ import qualified Data.Text.Lazy as Lazy (Text)
254247import qualified Data.Text as Strict (Text)
255248import qualified Data.Text as Strict.Text
256249import qualified Data.Vector as Vector
257−import qualified Generics.SOP.Type.Metadata as Type
258250import qualified GHC.Generics as GHC
259251import qualified PostgreSQL.Binary.Decoding as Decoding
260252import qualified PostgreSQL.Binary.Encoding as Encoding
261253
254+import Squeal.PostgreSQL.Alias
255+import Squeal.PostgreSQL.List
256+import Squeal.PostgreSQL.PG
262257import Squeal.PostgreSQL.Schema
263258
264259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
@@ -786,171 +781,3 @@ type it's applied to should be stored as a `PGfixarray`.
786781newtype FixArray arr = FixArray {getFixArray :: arr}
787782 deriving (Eq, Ord, Show, Read, GHC.Generic)
788783type instance PG (FixArray x) = 'PGfixarray (DimPG x) (FixPG x)
789−
790−type family DimPG (hask :: Type) :: [Nat] where
791− DimPG (x,x) = 2 ': DimPG x
792− DimPG (x,x,x) = 3 ': DimPG x
793− DimPG (x,x,x,x) = 4 ': DimPG x
794− DimPG (x,x,x,x,x) = 5 ': DimPG x
795− DimPG (x,x,x,x,x,x) = 6 ': DimPG x
796− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
797− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
798− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
799− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
800− DimPG x = '[]
801−
802−type family FixPG (hask :: Type) :: NullityType where
803− FixPG (x,x) = FixPG x
804− FixPG (x,x,x) = FixPG x
805− FixPG (x,x,x,x) = FixPG x
806− FixPG (x,x,x,x,x) = FixPG x
807− FixPG (x,x,x,x,x,x) = FixPG x
808− FixPG (x,x,x,x,x,x,x) = FixPG x
809− FixPG (x,x,x,x,x,x,x,x) = FixPG x
810− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
811− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
812− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
813− FixPG x = NullPG x
814−
815−{- | The `PG` type family embeds a subset of Haskell types
816−as Postgres types. As an open type family, `PG` is extensible.
817−
818−>>> :kind! PG LocalTime
819−PG LocalTime :: PGType
820−= 'PGtimestamp
821−
822−>>> newtype MyDouble = My Double
823−>>> :set -XTypeFamilies
824−>>> type instance PG MyDouble = 'PGfloat8
825−-}
826−type family PG (hask :: Type) :: PGType
827−type instance PG Bool = 'PGbool
828−type instance PG Int16 = 'PGint2
829−type instance PG Int32 = 'PGint4
830−type instance PG Int64 = 'PGint8
831−type instance PG Word16 = 'PGint2
832−type instance PG Word32 = 'PGint4
833−type instance PG Word64 = 'PGint8
834−type instance PG Scientific = 'PGnumeric
835−type instance PG Float = 'PGfloat4
836−type instance PG Double = 'PGfloat8
837−type instance PG Char = 'PGchar 1
838−type instance PG Text = 'PGtext
839−type instance PG Lazy.Text = 'PGtext
840−type instance PG String = 'PGtext
841−type instance PG ByteString = 'PGbytea
842−type instance PG Lazy.ByteString = 'PGbytea
843−type instance PG LocalTime = 'PGtimestamp
844−type instance PG UTCTime = 'PGtimestamptz
845−type instance PG Day = 'PGdate
846−type instance PG TimeOfDay = 'PGtime
847−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
848−type instance PG DiffTime = 'PGinterval
849−type instance PG UUID = 'PGuuid
850−type instance PG (NetAddr IP) = 'PGinet
851−type instance PG Value = 'PGjson
852−
853−{-| The `LabelsPG` type family calculates the constructors of a
854−Haskell enum type.
855−
856−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
857−>>> instance Generic Schwarma
858−>>> instance HasDatatypeInfo Schwarma
859−>>> :kind! LabelsPG Schwarma
860−LabelsPG Schwarma :: [Type.ConstructorName]
861−= '["Beef", "Lamb", "Chicken"]
862−-}
863−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
864− LabelsPG hask =
865− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
866−
867−{- | `RowPG` turns a Haskell record type into a `RowType`.
868−
869−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
870−>>> instance Generic Person
871−>>> instance HasDatatypeInfo Person
872−>>> :kind! RowPG Person
873−RowPG Person :: [(Symbol, NullityType)]
874−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
875−-}
876−type family RowPG (hask :: Type) :: RowType where
877− RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
878− RowPG (hask1, hask2, hask3) =
879− Join (RowPG hask1) (RowPG (hask2, hask3))
880− RowPG (hask1, hask2, hask3, hask4) =
881− Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
882− RowPG (hask1, hask2, hask3, hask4, hask5) =
883− Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
884− RowPG (P (col ::: head)) = '[col ::: NullPG head]
885− RowPG hask = RowOf (RecordCodeOf hask)
886−
887−type family RowOf (record :: [(Symbol, Type)]) :: RowType where
888− RowOf '[] = '[]
889− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
890−
891−{- | `NullPG` turns a Haskell type into a `NullityType`.
892−
893−>>> :kind! NullPG Double
894−NullPG Double :: NullityType
895−= 'NotNull 'PGfloat8
896−>>> :kind! NullPG (Maybe Double)
897−NullPG (Maybe Double) :: NullityType
898−= 'Null 'PGfloat8
899−-}
900−type family NullPG (hask :: Type) :: NullityType where
901− NullPG (Maybe hask) = 'Null (PG hask)
902− NullPG hask = 'NotNull (PG hask)
903−
904−{- | `TuplePG` turns a Haskell tuple type (including record types) into
905−the corresponding list of `NullityType`s.
906−
907−>>> :kind! TuplePG (Double, Maybe Char)
908−TuplePG (Double, Maybe Char) :: [NullityType]
909−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
910−-}
911−type family TuplePG (hask :: Type) :: [NullityType] where
912− TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))
913−
914−type family TupleOf (tuple :: [Type]) :: [NullityType] where
915− TupleOf '[] = '[]
916− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
917−
918−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
919− TupleCodeOf hask '[tuple] = tuple
920− TupleCodeOf hask '[] =
921− TypeError
922− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
923− ':$$: 'Text "It is a void type with no constructors."
924− )
925− TupleCodeOf hask (_ ': _ ': _) =
926− TypeError
927− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
928− ':$$: 'Text "It is a sum type with more than one constructor."
929− )
930−
931−-- | Calculates constructors of a datatype.
932−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
933− :: [Type.ConstructorInfo] where
934− ConstructorsOf ('Type.ADT _module _datatype constructors) =
935− constructors
936− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
937− '[constructor]
938−
939−-- | Calculates the name of a nullary constructor, otherwise
940−-- generates a type error.
941−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
942− :: Type.ConstructorName where
943− ConstructorNameOf ('Type.Constructor name) = name
944− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
945− ('Text "ConstructorNameOf error: non-nullary constructor "
946− ':<>: 'Text name)
947− ConstructorNameOf ('Type.Record name _fields) = TypeError
948− ('Text "ConstructorNameOf error: non-nullary constructor "
949− ':<>: 'Text name)
950−
951−-- | Calculate the names of nullary constructors.
952−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
953− :: [Type.ConstructorName] where
954− ConstructorNamesOf '[] = '[]
955− ConstructorNamesOf (constructor ': constructors) =
956− ConstructorNameOf constructor ': ConstructorNamesOf constructors
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+2
@@ -95,8 +95,10 @@ import Prelude hiding ((.), id)
9595import qualified Generics.SOP as SOP
9696import qualified GHC.Generics as GHC
9797
98+import Squeal.PostgreSQL.Alias
9899import Squeal.PostgreSQL.Binary
99100import Squeal.PostgreSQL.Expression
101+import Squeal.PostgreSQL.PG
100102import Squeal.PostgreSQL.Query
101103import Squeal.PostgreSQL.Render
102104import Squeal.PostgreSQL.Schema
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+3
@@ -279,7 +279,10 @@ import qualified Data.Text.Lazy as Lazy.Text
279279import qualified GHC.Generics as GHC
280280import qualified Generics.SOP as SOP
281281
282+import Squeal.PostgreSQL.Alias
282283import Squeal.PostgreSQL.Binary
284+import Squeal.PostgreSQL.List
285+import Squeal.PostgreSQL.PG
283286import Squeal.PostgreSQL.Render
284287import Squeal.PostgreSQL.Schema
285288
squeal-postgresql/src/Squeal/PostgreSQL/List.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , FlexibleContexts
4+ , GADTs
5+ , LambdaCase
6+ , MultiParamTypeClasses
7+ , OverloadedStrings
8+ , PolyKinds
9+ , QuantifiedConstraints
10+ , RankNTypes
11+ , ScopedTypeVariables
12+ , TypeApplications
13+ , TypeFamilies
14+ , TypeOperators
15+ , UndecidableInstances
16+#-}
17+
18+module Squeal.PostgreSQL.List
19+ ( SOP.NP (..)
20+ , (*:)
21+ , Join
22+ , (+++)
23+ , disjoin
24+ , AlignedList (..)
25+ , single
26+ , extractList
27+ , alignedMap
28+ , Elem
29+ , In
30+ , Length
31+ ) where
32+
33+import Control.Category
34+import Data.Kind
35+import Data.Type.Bool
36+import GHC.TypeLits
37+
38+import Generics.SOP as SOP
39+
40+import Squeal.PostgreSQL.Render
41+
42+-- | `Join` is simply promoted `++` and is used in @JOIN@s in
43+-- `Squeal.PostgreSQL.Query.FromClause`s.
44+type family Join xs ys where
45+ Join '[] ys = ys
46+ Join (x ': xs) ys = x ': Join xs ys
47+
48+-- | Concatenate `NP` lists.
49+(+++) :: NP f xs -> NP f ys -> NP f (Join xs ys)
50+xs +++ ys = case xs of
51+ Nil -> ys
52+ x :* xs' -> x :* (xs' +++ ys)
53+infixr 5 +++
54+
55+-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
56+disjoin
57+ :: forall xs ys expr. SListI xs
58+ => NP expr (Join xs ys)
59+ -> (NP expr xs, NP expr ys)
60+disjoin = case sList @xs of
61+ SNil -> \ys -> (Nil, ys)
62+ SCons -> \(x :* xsys) ->
63+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)
64+
65+-- | An `AlignedList` is a type-aligned list or free category.
66+data AlignedList p x0 x1 where
67+ Done :: AlignedList p x x
68+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
69+infixr 7 :>>
70+instance Category (AlignedList p) where
71+ id = Done
72+ (.) list = \case
73+ Done -> list
74+ step :>> steps -> step :>> (steps >>> list)
75+instance (forall t0 t1. RenderSQL (p t0 t1))
76+ => RenderSQL (AlignedList p x0 x1) where
77+ renderSQL = \case
78+ Done -> ""
79+ step :>> Done -> renderSQL step
80+ step :>> steps -> renderSQL step <> ", " <> renderSQL steps
81+
82+extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
83+extractList f = \case
84+ Done -> []
85+ step :>> steps -> (f step):extractList f steps
86+
87+alignedMap
88+ :: (forall z0 z1. p z0 z1 -> q z0 z1)
89+ -> AlignedList p x0 x1
90+ -> AlignedList q x0 x1
91+alignedMap f = \case
92+ Done -> Done
93+ x :>> xs -> f x :>> alignedMap f xs
94+
95+-- | A `single` step.
96+single :: p x0 x1 -> AlignedList p x0 x1
97+single step = step :>> Done
98+
99+-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
100+(*:) :: f x -> f y -> NP f '[x,y]
101+x *: y = x :* y :* Nil
102+infixl 9 *:
103+
104+-- | @Elem@ is a promoted `Data.List.elem`.
105+type family Elem x xs where
106+ Elem x '[] = 'False
107+ Elem x (x ': xs) = 'True
108+ Elem x (_ ': xs) = Elem x xs
109+
110+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
111+type family In x xs :: Constraint where
112+ In x xs = If (Elem x xs) (() :: Constraint)
113+ (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))
114+
115+{- | Calculate the `Length` of a type level list
116+
117+>>> :kind! Length '[Char,String,Bool,Double]
118+Length '[Char,String,Bool,Double] :: Nat
119+= 4
120+-}
121+type family Length (xs :: [k]) :: Nat where
122+ Length (x : xs) = 1 + Length xs
123+ Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+3−1
@@ -62,8 +62,10 @@ import GHC.TypeLits (KnownSymbol)
6262import qualified Generics.SOP as SOP
6363import qualified GHC.Generics as GHC
6464
65−import Squeal.PostgreSQL.Binary
65+import Squeal.PostgreSQL.Alias
6666import Squeal.PostgreSQL.Expression
67+import Squeal.PostgreSQL.List
68+import Squeal.PostgreSQL.PG
6769import Squeal.PostgreSQL.Render
6870import Squeal.PostgreSQL.Query
6971import Squeal.PostgreSQL.Schema
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+21−20
@@ -147,22 +147,23 @@ module Squeal.PostgreSQL.Migration
147147 , defaultMain
148148 ) where
149149
150−import Control.Category
151−import Control.Monad
152−import Data.ByteString (ByteString)
153−import Data.Foldable (traverse_)
154−import Data.Function ((&))
155−import Data.List ((\\))
156−import Data.Text (Text)
157−import qualified Data.Text.IO as T (putStrLn)
158−import Data.Time (UTCTime)
159−import Generics.SOP (K (..))
160−import qualified Generics.SOP as SOP
161−import qualified GHC.Generics as GHC
162−import Prelude hiding ((.), id)
163−import Squeal.PostgreSQL
164−import System.Environment
165−import UnliftIO (MonadIO (..))
150+import Control.Category
151+import Control.Monad
152+import Data.ByteString (ByteString)
153+import Data.Foldable (traverse_)
154+import Data.Function ((&))
155+import Data.List ((\\))
156+import Data.Text (Text)
157+import Data.Time (UTCTime)
158+import Generics.SOP (K (..))
159+import Prelude hiding ((.), id)
160+import Squeal.PostgreSQL
161+import System.Environment
162+import UnliftIO (MonadIO (..))
163+
164+import qualified Data.Text.IO as Text (putStrLn)
165+import qualified Generics.SOP as SOP
166+import qualified GHC.Generics as GHC
166167
167168-- | A `Migration` is a named "isomorphism" over a given category.
168169-- It should contain an inverse pair of `up` and `down`
@@ -437,17 +438,17 @@ defaultMain connectTo migrations = do
437438 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
438439
439440 displayListOfNames :: [Text] -> IO ()
440− displayListOfNames [] = T.putStrLn " None"
441+ displayListOfNames [] = Text.putStrLn " None"
441442 displayListOfNames xs =
442− let singleName n = T.putStrLn $ " - " <> n
443+ let singleName n = Text.putStrLn $ " - " <> n
443444 in traverse_ singleName xs
444445
445446 displayUnrunned :: [Text] -> IO ()
446447 displayUnrunned unrunned =
447− T.putStrLn "Migrations left to run:"
448+ Text.putStrLn "Migrations left to run:"
448449 >> displayListOfNames unrunned
449450
450451 displayRunned :: [Text] -> IO ()
451452 displayRunned runned =
452− T.putStrLn "Migrations already run:"
453+ Text.putStrLn "Migrations already run:"
453454 >> displayListOfNames runned
squeal-postgresql/src/Squeal/PostgreSQL/PG.hsnew file+297
@@ -0,0 +1,297 @@
1+
2+{-# LANGUAGE
3+ AllowAmbiguousTypes
4+ , DeriveFoldable
5+ , DeriveFunctor
6+ , DeriveGeneric
7+ , DeriveTraversable
8+ , DefaultSignatures
9+ , FlexibleContexts
10+ , FlexibleInstances
11+ , FunctionalDependencies
12+ , GADTs
13+ , LambdaCase
14+ , OverloadedStrings
15+ , MultiParamTypeClasses
16+ , ScopedTypeVariables
17+ , TypeApplications
18+ , TypeFamilies
19+ , TypeInType
20+ , TypeOperators
21+ , UndecidableInstances
22+ , UndecidableSuperClasses
23+#-}
24+
25+module Squeal.PostgreSQL.PG
26+ ( PG
27+ , NullPG
28+ , TuplePG
29+ , RowPG
30+ , Entity
31+ , SOP.P (..)
32+ , LabelsPG
33+ , DimPG
34+ , FixPG
35+ , TupleOf
36+ , TupleCodeOf
37+ , ConstructorsOf
38+ , ConstructorNameOf
39+ , ConstructorNamesOf
40+ ) where
41+
42+import Data.Aeson (Value)
43+import Data.Kind (Type)
44+import Data.Int (Int16, Int32, Int64)
45+import Data.Scientific (Scientific)
46+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
47+import Data.Word (Word16, Word32, Word64)
48+import Data.UUID.Types (UUID)
49+import GHC.TypeLits
50+import Network.IP.Addr (NetAddr, IP)
51+
52+import qualified Data.ByteString.Lazy as Lazy (ByteString)
53+import qualified Data.ByteString as Strict (ByteString)
54+import qualified Data.Text.Lazy as Lazy (Text)
55+import qualified Data.Text as Strict (Text)
56+import qualified Generics.SOP as SOP
57+import qualified Generics.SOP.Record as SOP
58+import qualified Generics.SOP.Type.Metadata as Type
59+
60+import Squeal.PostgreSQL.Alias
61+import Squeal.PostgreSQL.List
62+import Squeal.PostgreSQL.Schema
63+
64+{- | The `PG` type family embeds a subset of Haskell types
65+as Postgres types. As an open type family, `PG` is extensible.
66+
67+>>> :kind! PG LocalTime
68+PG LocalTime :: PGType
69+= 'PGtimestamp
70+
71+>>> newtype MyDouble = My Double
72+>>> :set -XTypeFamilies
73+>>> type instance PG MyDouble = 'PGfloat8
74+-}
75+type family PG (hask :: Type) :: PGType
76+type instance PG Bool = 'PGbool
77+type instance PG Int16 = 'PGint2
78+type instance PG Int32 = 'PGint4
79+type instance PG Int64 = 'PGint8
80+type instance PG Word16 = 'PGint2
81+type instance PG Word32 = 'PGint4
82+type instance PG Word64 = 'PGint8
83+type instance PG Scientific = 'PGnumeric
84+type instance PG Float = 'PGfloat4
85+type instance PG Double = 'PGfloat8
86+type instance PG Char = 'PGchar 1
87+type instance PG Strict.Text = 'PGtext
88+type instance PG Lazy.Text = 'PGtext
89+type instance PG String = 'PGtext
90+type instance PG Strict.ByteString = 'PGbytea
91+type instance PG Lazy.ByteString = 'PGbytea
92+type instance PG LocalTime = 'PGtimestamp
93+type instance PG UTCTime = 'PGtimestamptz
94+type instance PG Day = 'PGdate
95+type instance PG TimeOfDay = 'PGtime
96+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
97+type instance PG DiffTime = 'PGinterval
98+type instance PG UUID = 'PGuuid
99+type instance PG (NetAddr IP) = 'PGinet
100+type instance PG Value = 'PGjson
101+
102+{-| The `LabelsPG` type family calculates the constructors of a
103+Haskell enum type.
104+
105+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
106+>>> instance Generic Schwarma
107+>>> instance HasDatatypeInfo Schwarma
108+>>> :kind! LabelsPG Schwarma
109+LabelsPG Schwarma :: [Type.ConstructorName]
110+= '["Beef", "Lamb", "Chicken"]
111+-}
112+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
113+ LabelsPG hask =
114+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
115+
116+{- |
117+`RowPG` turns a Haskell `Type` into a `RowType`.
118+
119+`RowPG` may be applied to normal Haskell record types provided they
120+have the `Generic` and `HasDatatypeInfo` instances;
121+
122+>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
123+>>> instance Generic Person
124+>>> instance HasDatatypeInfo Person
125+>>> :kind! RowPG Person
126+RowPG Person :: [(Symbol, NullityType)]
127+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
128+
129+Or to tuples of `P` types;
130+
131+>>> :kind! RowPG (P ("id" ::: Int32), P ("foreign_id" ::: Int32))
132+RowPG (P ("id" ::: Int32), P ("foreign_id" ::: Int32)) :: [(Symbol,
133+ NullityType)]
134+= '[ '("id", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
135+
136+Or to tuples which mix `P` types and record types.
137+
138+>>> :kind! RowPG (P ("id" ::: Int32), Person, P ("foreign_id" ::: Int32))
139+RowPG (P ("id" ::: Int32), Person, P ("foreign_id" ::: Int32)) :: [(Symbol,
140+ NullityType)]
141+= '[ '("id", 'NotNull 'PGint4), '("name", 'NotNull 'PGtext),
142+ '("age", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]
143+-}
144+type family RowPG (hask :: Type) :: RowType where
145+ RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)
146+ RowPG (hask1, hask2, hask3) =
147+ Join (RowPG hask1) (RowPG (hask2, hask3))
148+ RowPG (hask1, hask2, hask3, hask4) =
149+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4))
150+ RowPG (hask1, hask2, hask3, hask4, hask5) =
151+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))
152+ RowPG (SOP.P (col ::: head)) = '[col ::: NullPG head]
153+ RowPG hask = RowOf (SOP.RecordCodeOf hask)
154+
155+type family RowOf (record :: [(Symbol, Type)]) :: RowType where
156+ RowOf '[] = '[]
157+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
158+
159+type family ColumnsOf (record :: [(Symbol, Type)]) :: ColumnsType where
160+ ColumnsOf '[] = '[]
161+ ColumnsOf (col ::: ty ': record) =
162+ col ::: 'NoDef :=> NullPG ty ': ColumnsOf record
163+
164+{- |
165+`Entity` turns a Haskell `Type` into a `ColumnsType`.
166+
167+`Entity` may be applied to normal Haskell record types provided they
168+have the `Generic` and `HasDatatypeInfo` instances;
169+
170+>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
171+>>> instance Generic Person
172+>>> instance HasDatatypeInfo Person
173+>>> :kind! Entity Person
174+Entity Person :: [(Symbol, (ColumnConstraint, NullityType))]
175+= '["name" ::: ('NoDef :=> 'NotNull 'PGtext),
176+ "age" ::: ('NoDef :=> 'NotNull 'PGint4)]
177+
178+Or to tuples of `P` types;
179+
180+>>> :kind! Entity (P ("id" ::: Int32), P ("foreign_id" ::: Int32))
181+Entity (P ("id" ::: Int32), P ("foreign_id" ::: Int32)) :: [(Symbol,
182+ ColumnType)]
183+= '[ '("id", 'Def :=> 'NotNull 'PGint4),
184+ "foreign_id" ::: ('Def :=> 'NotNull 'PGint4)]
185+
186+Or to tuples which mix `P` types and record types.
187+
188+>>> :kind! Entity (P ("id" ::: Int32), Person, P ("foreign_id" ::: Int32))
189+Entity (P ("id" ::: Int32), Person, P ("foreign_id" ::: Int32)) :: [(Symbol,
190+ ColumnType)]
191+= '[ '("id", 'Def :=> 'NotNull 'PGint4),
192+ '("name", 'NoDef :=> 'NotNull 'PGtext),
193+ '("age", 'NoDef :=> 'NotNull 'PGint4),
194+ "foreign_id" ::: ('Def :=> 'NotNull 'PGint4)]
195+-}
196+type family Entity (hask :: Type) :: ColumnsType where
197+ Entity (hask1, hask2) = Join (Entity hask1) (Entity hask2)
198+ Entity (hask1, hask2, hask3) =
199+ Join (Entity hask1) (Entity (hask2, hask3))
200+ Entity (hask1, hask2, hask3, hask4) =
201+ Join (Entity hask1) (Entity (hask2, hask3, hask4))
202+ Entity (hask1, hask2, hask3, hask4, hask5) =
203+ Join (Entity hask1) (Entity (hask2, hask3, hask4, hask5))
204+ Entity (SOP.P (col ::: head)) = '[col ::: 'Def :=> NullPG head]
205+ Entity hask = ColumnsOf (SOP.RecordCodeOf hask)
206+
207+{- | `NullPG` turns a Haskell type into a `NullityType`.
208+
209+>>> :kind! NullPG Double
210+NullPG Double :: NullityType
211+= 'NotNull 'PGfloat8
212+>>> :kind! NullPG (Maybe Double)
213+NullPG (Maybe Double) :: NullityType
214+= 'Null 'PGfloat8
215+-}
216+type family NullPG (hask :: Type) :: NullityType where
217+ NullPG (Maybe hask) = 'Null (PG hask)
218+ NullPG hask = 'NotNull (PG hask)
219+
220+{- | `TuplePG` turns a Haskell tuple type (including record types) into
221+the corresponding list of `NullityType`s.
222+
223+>>> :kind! TuplePG (Double, Maybe Char)
224+TuplePG (Double, Maybe Char) :: [NullityType]
225+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
226+-}
227+type family TuplePG (hask :: Type) :: [NullityType] where
228+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
229+
230+type family TupleOf (tuple :: [Type]) :: [NullityType] where
231+ TupleOf '[] = '[]
232+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
233+
234+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
235+ TupleCodeOf hask '[tuple] = tuple
236+ TupleCodeOf hask '[] =
237+ TypeError
238+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
239+ ':$$: 'Text "It is a void type with no constructors."
240+ )
241+ TupleCodeOf hask (_ ': _ ': _) =
242+ TypeError
243+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
244+ ':$$: 'Text "It is a sum type with more than one constructor."
245+ )
246+
247+-- | Calculates constructors of a datatype.
248+type family ConstructorsOf (datatype :: Type.DatatypeInfo)
249+ :: [Type.ConstructorInfo] where
250+ ConstructorsOf ('Type.ADT _module _datatype constructors) =
251+ constructors
252+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =
253+ '[constructor]
254+
255+-- | Calculates the name of a nullary constructor, otherwise
256+-- generates a type error.
257+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
258+ :: Type.ConstructorName where
259+ ConstructorNameOf ('Type.Constructor name) = name
260+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
261+ ('Text "ConstructorNameOf error: non-nullary constructor "
262+ ':<>: 'Text name)
263+ ConstructorNameOf ('Type.Record name _fields) = TypeError
264+ ('Text "ConstructorNameOf error: non-nullary constructor "
265+ ':<>: 'Text name)
266+
267+-- | Calculate the names of nullary constructors.
268+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
269+ :: [Type.ConstructorName] where
270+ ConstructorNamesOf '[] = '[]
271+ ConstructorNamesOf (constructor ': constructors) =
272+ ConstructorNameOf constructor ': ConstructorNamesOf constructors
273+
274+type family DimPG (hask :: Type) :: [Nat] where
275+ DimPG (x,x) = 2 ': DimPG x
276+ DimPG (x,x,x) = 3 ': DimPG x
277+ DimPG (x,x,x,x) = 4 ': DimPG x
278+ DimPG (x,x,x,x,x) = 5 ': DimPG x
279+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x
280+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
281+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
282+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
283+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
284+ DimPG x = '[]
285+
286+type family FixPG (hask :: Type) :: NullityType where
287+ FixPG (x,x) = FixPG x
288+ FixPG (x,x,x) = FixPG x
289+ FixPG (x,x,x,x) = FixPG x
290+ FixPG (x,x,x,x,x) = FixPG x
291+ FixPG (x,x,x,x,x,x) = FixPG x
292+ FixPG (x,x,x,x,x,x,x) = FixPG x
293+ FixPG (x,x,x,x,x,x,x,x) = FixPG x
294+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
295+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
296+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
297+ FixPG x = NullPG x
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+3−1
@@ -112,8 +112,10 @@ import GHC.TypeLits
112112
113113import qualified GHC.Generics as GHC
114114
115−import Squeal.PostgreSQL.Binary
115+import Squeal.PostgreSQL.Alias
116116import Squeal.PostgreSQL.Expression
117+import Squeal.PostgreSQL.List
118+import Squeal.PostgreSQL.PG
117119import Squeal.PostgreSQL.Render
118120import Squeal.PostgreSQL.Schema
119121
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+15−302
@@ -10,7 +10,6 @@ tables, schema, constraints, aliases, enumerated labels, and groupings.
1010It also defines useful type families to operate on these. Finally,
1111it defines an embedding of Haskell types into Postgres types.
1212-}
13−{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
1413{-# LANGUAGE
1514 AllowAmbiguousTypes
1615 , ConstraintKinds
@@ -54,33 +53,9 @@ module Squeal.PostgreSQL.Schema
5453 , TableConstraint (..)
5554 , TableConstraints
5655 , Uniquely
57− -- * Aliases
58− , (:::)
59− , Alias (..)
60− , IsLabel (..)
61− , Aliased (As)
62− , Aliasable (as)
63− , renderAliased
64− , Has
65− , HasUnique
66− , HasAll
67− , QualifiedAlias (..)
68− , IsQualified (..)
69− , HasIn
70− , IsNotElem
71− , AllUnique
72− , DefaultAliasable (..)
7356 -- * Enumerated Labels
7457 , IsPGlabel (..)
7558 , PGlabel (..)
76− -- * Grouping
77− , Grouping (..)
78− , GroupedBy
79− -- * Aligned lists
80− , AlignedList (..)
81− , single
82− , extractList
83− , alignedMap
8459 -- * Data Definitions
8560 , Create
8661 , Drop
@@ -88,14 +63,8 @@ module Squeal.PostgreSQL.Schema
8863 , Rename
8964 , ConstraintInvolves
9065 , DropIfConstraintsInvolve
91− -- * Lists
92− , Join
93− , disjoin
94− , Elem
95− , In
96− , Length
97− , (*:)
98− , (+++)
66+ , IsNotElem
67+ , AllUnique
9968 -- * Type Classifications
10069 , HasOid (..)
10170 , PGNum
@@ -118,20 +87,15 @@ module Squeal.PostgreSQL.Schema
11887 ) where
11988
12089import Control.Category
121−import Control.DeepSeq
122−import Data.ByteString (ByteString)
12390import Data.Kind
12491import Data.Monoid hiding (All)
125−import Data.String
12692import Data.Type.Bool
12793import Data.Word (Word32)
12894import Generics.SOP
129−import GHC.OverloadedLabels
13095import GHC.TypeLits
13196import Prelude hiding (id, (.))
13297
133−import qualified GHC.Generics as GHC
134−
98+import Squeal.PostgreSQL.Alias
13599import Squeal.PostgreSQL.Render
136100
137101-- | `PGType` is the promoted datakind of PostgreSQL types.
@@ -216,11 +180,6 @@ data NullityType
216180type (:=>) constraint ty = '(constraint,ty)
217181infixr 7 :=>
218182
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)
222−infixr 6 :::
223−
224183-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
225184-- A column can be assigned a default value.
226185-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
@@ -327,203 +286,6 @@ type family TableToColumns (table :: TableType) :: ColumnsType where
327286type family TableToRow (table :: TableType) :: RowType where
328287 TableToRow tab = ColumnsToRow (TableToColumns tab)
329288
330−-- | `Grouping` is an auxiliary namespace, created by
331−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
332−-- for typesafe aggregation
333−data Grouping
334− = Ungrouped -- ^ no aggregation permitted
335− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
336−
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.
340−-}
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 #-}
346− ( KnownSymbol table
347− , KnownSymbol column
348− , GroupedBy table column bys
349− ) => GroupedBy table column (tabcol ': bys)
350−
351−-- | `Alias`es are proxies for a type level string or `Symbol`
352−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
353−--
354−-- >>> :set -XOverloadedLabels
355−-- >>> #foobar :: Alias "foobar"
356−-- Alias
357−data Alias (alias :: Symbol) = Alias
358− deriving (Eq,GHC.Generic,Ord,Show,NFData)
359−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
360− fromLabel = Alias
361−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
362− fromLabel = fromLabel :* Nil
363−-- | >>> printSQL (#jimbob :: Alias "jimbob")
364−-- "jimbob"
365−instance KnownSymbol alias => RenderSQL (Alias alias) where
366− renderSQL = doubleQuoted . fromString . symbolVal
367−
368−-- | >>> import Generics.SOP (NP(..))
369−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
370−-- "jimbob", "kandi"
371−instance All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
372− renderSQL
373− = commaSeparated
374− . hcollapse
375− . hcmap (Proxy @KnownSymbol) (K . renderSQL)
376−
377−-- | The `As` operator is used to name an expression. `As` is like a demoted
378−-- version of `:::`.
379−--
380−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
381−-- As (Just "hello") Alias
382−data Aliased expression aliased where
383− As
384− :: KnownSymbol alias
385− => expression ty
386− -> Alias 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
397−
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
402− , aliased -> alias
403− where as :: expression -> Alias alias -> aliased
404−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
405− (expression ty)
406− (Aliased expression aliased)
407− where
408− as = As
409−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
410− (expression ty)
411− (NP (Aliased expression) tys)
412− where
413− expression `as` alias = expression `As` alias :* Nil
414−
415−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
416−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
417−-- "Just AS \"an_int\""
418−renderAliased
419− :: (forall ty. expression ty -> ByteString)
420− -> Aliased expression aliased
421− -> ByteString
422−renderAliased render (expression `As` alias) =
423− render expression <> " AS " <> renderSQL alias
424−
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]
428−
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
439−
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.
443−-}
444−class HasIn fields field where
445−instance (Has alias fields field) => HasIn fields (alias ::: field) where
446−
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
454−
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
459−
460−{- |
461−The `DefaultAliasable` class is intended to help with Scrap your Nils
462−for default inserts and updates.
463−-}
464−class KnownSymbol alias
465− => DefaultAliasable alias aliased | aliased -> alias where
466− defaultAs :: Alias alias -> aliased
467−
468−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
469−-- a list of @subfields@.
470−class
471− ( All KnownSymbol aliases
472− ) => HasAll
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)
481−
482−-- | Analagous to `IsLabel`, the constraint
483−-- `IsQualified` defines `!` for a column alias qualified
484−-- by a table alias.
485−class IsQualified table column expression where
486− (!) :: Alias table -> Alias column -> expression
487− infixl 9 !
488−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
489−
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.
493−
494−>>> :{
495−let
496− alias1 :: QualifiedAlias "sch" "tab"
497− alias1 = #sch ! #tab
498− alias2 :: QualifiedAlias "public" "vw"
499− alias2 = #vw
500−in printSQL alias1 >> printSQL alias2
501−:}
502−"sch"."tab"
503−"vw"
504−-}
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
517−
518−instance (KnownSymbol q, KnownSymbol a)
519− => RenderSQL (QualifiedAlias q a) where
520− renderSQL _ =
521− let
522− qualifier = renderSQL (Alias @q)
523− alias = renderSQL (Alias @a)
524− in
525− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
526−
527289-- | @Elem@ is a promoted `Data.List.elem`.
528290type family Elem x xs where
529291 Elem x '[] = 'False
@@ -584,22 +346,6 @@ type family NullifyFrom (tables :: FromType) :: FromType where
584346 NullifyFrom (table ::: columns ': tables) =
585347 table ::: NullifyRow columns ': NullifyFrom tables
586348
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
590− Join '[] ys = ys
591− Join (x ': xs) ys = x ': Join xs ys
592−
593−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
594−disjoin
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)
602−
603349-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
604350-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
605351-- `Squeal.PostgreSQL.Definition.addColumn`.
@@ -734,48 +480,15 @@ type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
734480-- | Is a type a valid JSON type?
735481type PGJsonType = '[ 'PGjson, 'PGjsonb ]
736482
737−-- | An `AlignedList` is a type-aligned list or free category.
738−data AlignedList p x0 x1 where
739− Done :: AlignedList p x x
740− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
741−infixr 7 :>>
742−instance Category (AlignedList p) where
743− id = Done
744− (.) list = \case
745− Done -> list
746− step :>> steps -> step :>> (steps >>> list)
747−instance (forall t0 t1. RenderSQL (p t0 t1))
748− => RenderSQL (AlignedList p x0 x1) where
749− renderSQL = \case
750− Done -> ""
751− step :>> Done -> renderSQL step
752− step :>> steps -> renderSQL step <> ", " <> renderSQL steps
753−
754−extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]
755−extractList f = \case
756− Done -> []
757− step :>> steps -> (f step):extractList f steps
758−
759−alignedMap
760− :: (forall z0 z1. p z0 z1 -> q z0 z1)
761− -> AlignedList p x0 x1
762− -> AlignedList q x0 x1
763−alignedMap f = \case
764− Done -> Done
765− x :>> xs -> f x :>> alignedMap f xs
766−
767−-- | A `single` step.
768−single :: p x0 x1 -> AlignedList p x0 x1
769−single step = step :>> Done
770−
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
774−infixl 9 *:
775−
776−-- | Concatenate `NP` lists.
777−(+++) :: NP f xs -> NP f ys -> NP f (Join xs ys)
778−xs +++ ys = case xs of
779− Nil -> ys
780− x :* xs' -> x :* (xs' +++ ys)
781−infixr 5 +++
483+-- | Utility class for `AllUnique` to provide nicer error messages.
484+class IsNotElem x isElem where
485+instance IsNotElem x 'False where
486+instance (TypeError ( 'Text "Cannot assign to "
487+ ':<>: 'ShowType alias
488+ ':<>: 'Text " more than once"))
489+ => IsNotElem '(alias, a) 'True where
490+
491+-- | No elem of @xs@ appears more than once, in the context of assignment.
492+class AllUnique (xs :: [(Symbol, a)]) where
493+instance AllUnique '[] where
494+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hsnew file+39
@@ -0,0 +1,39 @@
1+{-|
2+Module: Squeal.PostgreSQL.Tutorail
3+Description: Squeal tutorial module
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+== `P` records
9+
10+A `P` record is an ad-hoc, anonymous record constructed
11+as a tuple of `P`s, a datatype from `Generics.SOP.Record`, like so:
12+
13+>>> type Rec = (P ("foo" ::: Double), P ("bar" ::: Char))
14+
15+Let's see what the image of `Rec` is under the `RowPG` type family.
16+
17+>>> :kind! RowPG Rec
18+RowPG Rec :: [(Symbol, NullityType)]
19+= '[ '("foo", 'NotNull 'PGfloat8), "bar" ::: 'NotNull ('PGchar 1)]
20+
21+`P` records are ad-hoc, anonymous records so unlike Haskell records
22+you don't have to define them outside of their use site, for instance
23+in the row type parameter of a `Query_` type family.
24+
25+>>> :{
26+let
27+ query :: Query_ schemas () (P ("foo" ::: Double))
28+ query = values_ (1 `as` #foo)
29+in printSQL query
30+:}
31+SELECT * FROM (VALUES (1)) AS t ("foo")
32+
33+You can even mix `P` records with normal Haskell records, which is very
34+useful for creating entity types, Haskell records with associated ids.
35+
36+>>> data Row = Row {foo :: Double, bar :: Char} deriving (GHC.Generic)
37+-}
38+
39+module Squeal.PostgreSQL.Tutorial where