pg-schema (empty) → 0.5.0.0
raw patch · 36 files changed
+5941/−0 lines, 36 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, case-insensitive, containers, deepseq, directory, exceptions, flat, hashable, hedgehog, mtl, pg-schema, postgresql-simple, resource-pool, scientific, singletons, singletons-th, tasty, tasty-hedgehog, text, time, unordered-containers, uuid-types, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +21/−0
- pg-schema.cabal +293/−0
- src/PgSchema/Ann.hs +672/−0
- src/PgSchema/DML.hs +141/−0
- src/PgSchema/DML/Delete.hs +35/−0
- src/PgSchema/DML/Insert.hs +56/−0
- src/PgSchema/DML/Insert/Types.hs +75/−0
- src/PgSchema/DML/InsertJSON.hs +295/−0
- src/PgSchema/DML/Select.hs +445/−0
- src/PgSchema/DML/Select/Types.hs +395/−0
- src/PgSchema/DML/Update.hs +61/−0
- src/PgSchema/GenDot.hs +78/−0
- src/PgSchema/Generation.hs +467/−0
- src/PgSchema/Import.hs +46/−0
- src/PgSchema/Schema.hs +296/−0
- src/PgSchema/Schema/Catalog.hs +345/−0
- src/PgSchema/Schema/Info.hs +74/−0
- src/PgSchema/Types.hs +391/−0
- src/PgSchema/Utils/CamelToSnake.hs +35/−0
- src/PgSchema/Utils/Instances.hs +101/−0
- src/PgSchema/Utils/Internal.hs +52/−0
- src/PgSchema/Utils/ShowType.hs +69/−0
- src/PgSchema/Utils/TF.hs +62/−0
- test-gen/Main.hs +107/−0
- test-pgs/Main.hs +52/−0
- test-pgs/Sch.hs +483/−0
- test-pgs/Tests/Aggregates.hs +11/−0
- test-pgs/Tests/BaseConverts.hs +109/−0
- test-pgs/Tests/Conditions.hs +120/−0
- test-pgs/Tests/Hierarchy.hs +165/−0
- test-pgs/Tests/Path.hs +17/−0
- test-pgs/Utils.hs +219/−0
- test/PgTagJsonSpec.hs +114/−0
- test/json-spec.hs +6/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for pg-schema++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dmitry Olshansky (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Dmitry Olshansky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,21 @@+# pg-schema++*pg-schema* is a Haskell library that lifts a PostgreSQL schema description to the type level and gives you type-safe, compile-time-checked access to data.++The core idea is a type provider: from a live database (tables, primary and unique keys, foreign keys, column types—including arrays and enums) a schema representation is built that you then use with ordinary GHC types. You can have any number of such schemas; each may include any subset of tables.++To generate schemas you create a separate application that uses `PgSchema.Generation.updateSchemaFile` to produce `.hs` files describing each schema (sets of tables, relationships between them, and the types in use).++For reading and writing data, use the `PgSchema.DML` module. Queries are built from a typed EDSL, without hand-written SQL. You can describe data trees (nested records along relationships), including inserting an entire tree in one database round-trip (JSON is used internally), and fetching a tree with a single SELECT, with predicates, ordering, and limits at each level of the tree (`WHERE`, `ORDER BY`, `LIMIT/OFFSET`, and so on).++Inserts and reads use either ordinary Haskell records with a Generic instance or types of the form `"fld1" := Int32 :. "fld2" := Maybe Text`. Field names in Haskell records must match those in the database (with renaming supported) but you can work with any subset of the table's fields. Navigation along relationships uses foreign-key constraint names. Types and nullability are checked against the data layout.++SELECT and INSERT/UPSERT are implemented for the nested structures. UPDATE and DELETE apply to a single table.++When reading data, an EDSL sets conditions, ordering, and grouping. All of these operations are type-safe.++For inserts and updates, additional compile-time checks derive from database constraints—for example, inserts verify that mandatory fields are present at every level.++## Requirements++**GHC ≥ 9.10**. Theoretically, one could target older GHC version at the cost of a slightly worse API without `RequiredTypeArguments`.
+ pg-schema.cabal view
@@ -0,0 +1,293 @@+cabal-version: 3.12+name: pg-schema+version: 0.5.0.0+category: Database+author: Dmitry Olshansky+maintainer: olshanskydr@gmail.com+copyright: Dmitry Olshansky+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+synopsis: Type-level definition of database schema and safe DML for PostgreSQL.+description:+ == Schema definition++ Use `updateSchemaFile` function from "PgSchema.Generation" module to generate type-level definition of database schema.+ You can make several schemas with any parts of your database.++ Usually you make executable which imports this module and run it to generate schema definition.+ You can run it on CI to check if schema definition is up to date.++ == Safe DML for PostgreSQL++ Use "PgSchema.DML" module to describe and generate (in runtime) safe DML for PostgreSQL.+ All operations are statically checked and you can't write invalid SQL.++ With @pg-schema@ you can select or insert/upsert data into tree-like ADT in one request.++ === Example+ Let's say++ - we have a database with tables: "orders", "order_positions", "articles".+ - There are articles with ids 41 and 42.+ - We have generated `MySch` schema with `updateSchemaFile` function from "PgSchema.Generation" module.++ Then we can write a function to insert an order with order positions.+ And select orders with order positions and articles in one request using some conditions for orders and order positions that return in order.++ @+ data Order = Order { num :: Text, createdAt :: Day, items :: [OrdPos] } deriving Generic+ data OrdPos = OrdPos { id :: Int32, num :: Int32, article :: Article, price :: Double } deriving Generic+ data Article = Article { id :: Int32, name :: Text } deriving Generic+ type MyAnn tabName = 'Ann 5 CamelToSnake MySch ("dbSchema" ->> tabName)+ ...+ do+ -- insert an order with order positions+ void $ insertJSON_ (MyAnn "orders") conn+ [ "num" =: "num1" :. "ord__ord_pos" =:+ [ "num" =: 1 :. "articleId" =: 42 :. "price" =: 10+ , "num" =: 2 :. "articleId" =: 41 :. "price" =: 15 ] ]++ -- select orders+ (xs :: [Order]) <- selectSch (MyAnn "orders") conn $ qRoot do+ qWhere $ "created_at" >? someDay+ &&& pchild "ord__ord_pos" defTabParam+ (pparent "ord_pos__article" $ "name" ~~? "%pencil%")+ qOrderBy [descf "created_at", descf "num"]+ qPath "ord__ord_pos" do+ qWhere $ pparent "ord_pos__article" $ "name" ~~? "%pencil%"+ qOrderBy [ascf "num"]+ qLimit 20+ @++ === Module structure++ * "PgSchema.Generation" - module with generation functions.+ Usually you make executable which generates schema definition using this module.+ * "PgSchema.DML" - module with DML functions. Import this module into your application and use it to generate safe DML for PostgreSQL.+ * "PgSchema.Import" - generated schema module imports this module.++homepage: https://github.com/odr/pg-schema/tree/master/pg-schema#readme+bug-reports: https://github.com/odr/pg-schema/issues+extra-doc-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/odr/pg-schema++flag arbitrary+ description: Make Arbitrary instances for all types (Enums, PgTag, SchList)+ manual: True+ default: False++flag debug+ description: Trace queries+ manual: True+ default: False++flag flat+ description: Make Flat instances for all types (Enums, PgTag, SchList)+ manual: True+ default: False++flag hashable+ description: Make Hashable instances for all types (Enums, PgTag, SchList)+ manual: True+ default: False++library+ exposed-modules:+ -- PgSchema+ PgSchema.DML+ PgSchema.Generation+ PgSchema.Import+ PgSchema.Schema.Catalog+ PgSchema.Schema.Info+ PgSchema.GenDot+ other-modules:+ PgSchema.Ann+ PgSchema.DML.Delete+ PgSchema.DML.Insert+ PgSchema.DML.InsertJSON+ PgSchema.DML.Insert.Types+ PgSchema.DML.Select+ PgSchema.DML.Select.Types+ PgSchema.DML.Update+ PgSchema.Schema+ PgSchema.Types+ PgSchema.Utils.CamelToSnake+ PgSchema.Utils.Instances+ PgSchema.Utils.Internal+ PgSchema.Utils.TF+ PgSchema.Utils.ShowType+ --+ Paths_pg_schema+ PackageInfo_pg_schema+ autogen-modules:+ Paths_pg_schema+ PackageInfo_pg_schema+ hs-source-dirs: src+ build-depends:+ base >= 4.20 && < 5+ , aeson >= 2.0 && < 2.3+ , bytestring >= 0.10 && < 0.13+ , case-insensitive >= 1.0 && < 1.3+ , containers >= 0.7 && < 0.9+ , directory >= 1.3 && < 1.5+ , exceptions >= 0.9 && < 0.11+ , mtl >= 2.0 && < 2.4+ , postgresql-simple >= 0.6 && < 0.8+ , scientific >= 0.2 && < 0.4+ , singletons >= 3.0.3 && < 3.1+ , singletons-th >= 3.4 && < 3.6+ , text >= 2.0 && < 2.2+ , time >= 1.12 && < 2+ , uuid-types >= 1.0 && < 1.1+ if flag(flat)+ build-depends: flat >= 0.6 && < 0.7+ cpp-options: -DMK_FLAT+ if flag(arbitrary)+ build-depends:+ QuickCheck >= 2.14.0 && < 2.18+ cpp-options: -DMK_ARBITRARY+ if flag(hashable)+ build-depends:+ hashable >= 1.5.1 && < 1.6+ cpp-options: -DMK_HASHABLE+ if flag(debug)+ cpp-options: -DDEBUG+ ghc-options:+ -Wall+ -Wunused-packages+ default-language: GHC2021+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ ExplicitNamespaces+ DataKinds+ -- ^^^ added in GHC2024+ DerivingStrategies+ FunctionalDependencies+ LambdaCase+ -- ^^^ added in GHC2024+ MultiWayIf+ OverloadedRecordDot+ OverloadedStrings+ PatternSynonyms+ RecordWildCards+ RequiredTypeArguments+ TemplateHaskell+ TypeAbstractions+ TypeFamilies+ ViewPatterns++test-suite json-spec+ type: exitcode-stdio-1.0+ main-is: json-spec.hs+ other-modules:+ PgTagJsonSpec+ -- Paths and PackageInfo+ Paths_pg_schema+ PackageInfo_pg_schema+ autogen-modules:+ Paths_pg_schema+ PackageInfo_pg_schema+ hs-source-dirs: test+ build-depends:+ base+ , aeson+ , bytestring+ , pg-schema+ , postgresql-simple >= 0.6 && < 0.8+ , text+ default-language: GHC2021+ default-extensions:+ DataKinds+ OverloadedStrings+ RequiredTypeArguments+ TypeAbstractions+ TypeFamilies+ UndecidableInstances+ ghc-options: -Wall++executable test-gen+ main-is: Main.hs+ other-modules:+ -- Paths and PackageInfo+ Paths_pg_schema+ PackageInfo_pg_schema+ autogen-modules:+ Paths_pg_schema+ PackageInfo_pg_schema+ build-depends:+ base >= 4.21.0 && < 4.22+ , bytestring >= 0.12.2 && < 0.13+ , directory >= 1.3.9 && < 1.4+ , pg-schema+ , postgresql-simple >= 0.6 && < 0.8+ hs-source-dirs: test-gen+ default-language: GHC2021++test-suite test-pgs+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Sch+ Tests.Aggregates+ Tests.BaseConverts+ Tests.Conditions+ Tests.Hierarchy+ Tests.Path+ Utils+ -- Paths and PackageInfo+ Paths_pg_schema+ PackageInfo_pg_schema+ autogen-modules:+ Paths_pg_schema+ PackageInfo_pg_schema+ hs-source-dirs: test-pgs+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ ExplicitNamespaces+ DataKinds+ -- ^^^ added in GHC2024+ DerivingStrategies+ FunctionalDependencies+ LambdaCase+ -- ^^^ added in GHC2024+ MultiWayIf+ OverloadedRecordDot+ OverloadedStrings+ PatternSynonyms+ RecordWildCards+ RequiredTypeArguments+ TemplateHaskell+ TypeAbstractions+ TypeFamilies+ ViewPatterns+ build-depends:+ base,+ aeson,+ pg-schema,+ bytestring,+ singletons,+ case-insensitive,+ hedgehog >= 1.1,+ postgresql-simple,+ resource-pool,+ scientific,+ tasty >= 1.4,+ tasty-hedgehog >= 1.2,+ text,+ time,+ unordered-containers,+ uuid-types,+ vector,+ -- they can be excluded by flags+ hashable,+ deepseq+ ---------------+ default-language: GHC2021
+ src/PgSchema/Ann.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE UndecidableInstances #-}+module PgSchema.Ann where++import Data.Aeson+import Data.Aeson.Types (Pair, Parser)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as Key+import Data.Coerce+import Data.Singletons.TH (genDefunSymbols)+import Data.Type.Bool+import Data.Typeable+import Data.Text qualified as T+import Data.Kind+import Database.PostgreSQL.Simple.ToField(ToField(..), Action, toJSONField)+import Database.PostgreSQL.Simple.FromField(FromField(..), fromJSONField)+import Database.PostgreSQL.Simple.ToRow(ToRow(..))+import Database.PostgreSQL.Simple.FromRow(FromRow(..), RowParser, field)+import GHC.Generics+import GHC.Int+import GHC.TypeLits+import GHC.TypeError as TE+import PgSchema.Schema+import PgSchema.Types+import PgSchema.Utils.Internal+import Data.Singletons as SP+import PgSchema.Utils.TF as SP++++-- $setup+-- >>> import PgSchema.Schema.Catalog+-- >>> import Database.PostgreSQL.Simple+-- >>> conn <- connectPostgreSQL ""++-- | Type-level annotation: enforce constraints at compile time+-- and drive demoted types used to generate correct SQL.+-- 'annRen' and 'annSch' are fixed for the whole DML-operation.+-- 'annDepth' and 'annTab' are changed while traversing the structure of the ADT.+--+data Ann = Ann+ { annRen :: Renamer -- ^ Renamer to convert Haskell names to database names.+ , annSch :: Type -- ^ Schema with tables, relations and types.+ , annDepth :: Nat+ -- ^ Depth of the nested relations. It is mostly used to prevent cycles in types.+ , annTab :: NameNSK -- ^ Name of the root table.+ }++type family AnnSch (ann :: Ann) where+ AnnSch ('Ann ren sch depth tab) = sch++data ColInfo (p :: Type) = ColInfo+ { ciField :: SymNat+ , ciType :: Type+ , ciDbField :: Symbol+ , ciInfo :: RecField' Symbol p+ }++-- | Renamer is a type-level function from 'Symbol' to 'Symbol'.+type Renamer = Symbol ~> Symbol++-- | Apply renamer to symbol.+--+-- Like 'Data.Singletons.Apply' but specialized for 'Symbol'.+--+-- To make your own Renamer, typically you make+--+-- * data MyRenamer :: Renamer+-- * closed type family: `type family MyRenamerImpl (s :: Symbol) :: Symbol where ... `+-- * type instance ApplyRenamer MyRenamer s = MyRenamerImpl s+--+type family ApplyRenamer (renamer :: Renamer) (s :: Symbol) :: Symbol++-- | Renamer that does not change the symbol.+data RenamerId :: Renamer++type instance ApplyRenamer RenamerId s = s++--------------------------------------------------------------------------------+-- Case dispatch+--------------------------------------------------------------------------------++data ColsCase = NonGenericCase | GenericCase++type family ColsCaseOf (r :: Type) :: ColsCase where+ ColsCaseOf (a :. b) = 'NonGenericCase+ ColsCaseOf ((_ :: Symbol) := _) = 'NonGenericCase+ ColsCaseOf r = 'GenericCase++--------------------------------------------------------------------------------+-- CCols / CColsCase+--------------------------------------------------------------------------------++class CColsCase ann r (ColsCaseOf r) => CCols ann r where+ type Cols ann r :: [ColInfo NameNSK]++instance CColsCase ann r (ColsCaseOf r) => CCols ann r where+ type Cols ann r = ColsWithCase ann r (ColsCaseOf r)++class CColsCase (ann :: Ann) (r :: Type) (c :: ColsCase) where+ type ColsWithCase ann r c :: [ColInfo NameNSK]++instance CColsCase ann r 'NonGenericCase where+ type ColsWithCase ann r 'NonGenericCase = ColsNonGeneric ann r++instance Generic r => CColsCase ann r 'GenericCase where+ type ColsWithCase ann r 'GenericCase = GCols ann (Rep r)++--------------------------------------------------------------------------------+-- ColsNonGeneric (closed TF: (:.) and (:=))+--------------------------------------------------------------------------------++type family ColsNonGeneric (ann :: Ann) r :: [ColInfo NameNSK] where+ ColsNonGeneric ann (a :. b) = Normalize (Cols ann a SP.++ Cols ann b)+ ColsNonGeneric ann (fld := t) = Col ann fld t++--------------------------------------------------------------------------------+-- Col / ColFI (per-field, reused by GCols)+--------------------------------------------------------------------------------++type family Col (ann :: Ann) (fld :: Symbol) t :: [ColInfo NameNSK] where+ Col ann fld () = '[]+ Col ann fld (Aggr ACount Int64) =+ '[ 'ColInfo '(fld, 0) (Aggr ACount Int64) fld+ ('RFAggr ('FldDef ("pg_catalog" ->> "int8") False False) 'ACount 'True) ]+ Col ann fld (Aggr' ACount Int64) =+ '[ 'ColInfo '(fld, 0) (Aggr' ACount Int64) fld+ ('RFAggr ('FldDef ("pg_catalog" ->> "int8") False False) 'ACount 'True) ]+ Col ('Ann ren sch d tab) fld t =+ ColFI ('Ann ren sch d tab) fld (TDBFieldInfo sch tab (ApplyRenamer ren fld)) t++type family ColFI (ann :: Ann) (fld :: Symbol) (fi :: RecFieldK NameNSK) t+ :: [ColInfo NameNSK] where+ ColFI ('Ann ren sch _ _) fld ('RFPlain ('FldDef tn False def)) (PgArr t) =+ '[ 'ColInfo '(fld, 0) (PgTag (TypElem (TTypDef sch tn)) (PgArr t))+ (ApplyRenamer ren fld) (RFPlain ('FldDef tn False def))]+ ColFI ('Ann ren sch _ _) fld ('RFPlain ('FldDef tn True def)) (Maybe (PgArr t)) =+ '[ 'ColInfo '(fld, 0) (Maybe (PgTag (TypElem (TTypDef sch tn)) (PgArr t)))+ (ApplyRenamer ren fld) (RFPlain ('FldDef tn True def))]+ -- RFFromHere: Maybe r+ ColFI ('Ann ren sch d _) fld ('RFFromHere (toTab :: NameNSK) refs) (Maybe r) =+ '[ 'ColInfo '(fld, 0) (Maybe (PgTag (AnnRefTabDepth ('Ann ren sch d toTab) toTab) r))+ (ApplyRenamer ren fld) ('RFFromHere toTab refs) ]+ -- RFFromHere: r (non-Maybe)+ ColFI ('Ann ren sch d _) fld ('RFFromHere (toTab :: NameNSK) refs) r =+ '[ 'ColInfo '(fld, 0) (PgTag (AnnRefTabDepth ('Ann ren sch d toTab) toTab) r)+ (ApplyRenamer ren fld) ('RFFromHere toTab refs) ]+ ColFI ('Ann ren sch d _) fld ('RFToHere (fromTab :: NameNSK) refs) [t] =+ '[ 'ColInfo '(fld, 0) [PgTag (AnnRefTabDepth ('Ann ren sch d fromTab) fromTab) t]+ (ApplyRenamer ren fld) ('RFToHere fromTab refs) ]+ ColFI ('Ann ren sch d _) fld fd t = '[ 'ColInfo '(fld, 0) t (ApplyRenamer ren fld) fd ]+ ColFI ann fld ('RFSelfRef tab refs) [t] = ColFI ann fld ('RFToHere tab refs) [t]+ ColFI ann fld ('RFSelfRef tab refs) t = ColFI ann fld ('RFFromHere tab refs) t+--------------------------------------------------------------------------------+-- GCols (closed TF: Generic Rep)+--------------------------------------------------------------------------------++type family GCols ann (rep :: Type -> Type) :: [ColInfo NameNSK] where+ GCols ann (D1 d (C1 c flds)) = Normalize (GCols ann flds)+ GCols ann (a :*: b) = GCols ann a SP.++ GCols ann b+ GCols ann (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) = Col ann fld t+ GCols ann rep = TypeError+ ( Text "Only Product types with fields are supported in pg-schema."+ :$$: Text "(sum types, empty, or missing field selector are not supported)"+ :$$: Text ""+ :$$: Text "But I've got " :<>: ShowType rep )++--------------------------------------------------------------------------------+-- Normalize (SymNat numbering)+--------------------------------------------------------------------------------++type family AddNum (xs :: [ColInfo p]) (cnts :: [SymNat])+ (accCnts :: [SymNat]) :: [ColInfo p]+ where+ AddNum '[] _ _ = '[]+ AddNum ('ColInfo '(s,_) t f fi : xs) '[] accCnts =+ 'ColInfo '(s,0) t f fi ': AddNum xs ('(s,0) ': accCnts) '[]+ AddNum ('ColInfo '(s,_) t f fi : xs) ('(s,n) ': rest) accCnts =+ 'ColInfo '(s, n+1) t f fi ': AddNum xs (('(s,n+1) ': accCnts) SP.++ rest) '[]+ AddNum ('ColInfo '(s,x) t f fi : xs) ('(s',n) ': rest) accCnts =+ AddNum ('ColInfo '(s,x) t f fi : xs) rest ('(s',n) ': accCnts)++type Normalize xs = AddNum xs '[] '[]++--------------------------------------------------------------------------------+-- ToJSON for PgTag Ann r+--------------------------------------------------------------------------------++instance+ (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, ToJSONCols ann colsCase cols r)+ => ToJSON (PgTag ann r) where+ toJSON (PgTag r) = Object (KM.fromList (toPairs @ann @colsCase @cols r))+ toEncoding (PgTag r) = pairs (foldMap (uncurry (.=)) $ toPairs @ann @colsCase @cols r)++instance+ (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromJSONCols ann colsCase cols r)+ => FromJSON (PgTag ann r) where+ parseJSON v = PgTag <$> parseJSONCols @ann @colsCase @cols v++-- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint")+-- >>> rel = PgRelation{ constraint__namespace = PgTag "a", conname = "b", constraint__class = PgClassShort (PgTag "c") "d", constraint__fclass = PgClassShort (PgTag "e") "f", conkey = pgArr' [1,2], confkey = pgArr' [] }+-- >>> rec = "conname" =: ("x" :: T.Text) :. "conname" =: ("z" :: T.Text) :. rel :. "conname" =: ("y" :: T.Text)+-- >>> toJSON $ PgTag @AnnRel rec+-- >>> fromJSON (toJSON $ PgTag @AnnRel rec) == Success (PgTag @AnnRel rec)+-- Object (fromList [("confkey",Array []),("conkey",Array [Number 1.0,Number 2.0]),("conname",String "x"),("conname___1",String "z"),("conname___2",String "b"),("conname___3",String "y"),("constraint__class",Object (fromList [("class__namespace",Object (fromList [("nspname",String "c")])),("relname",String "d")])),("constraint__fclass",Object (fromList [("class__namespace",Object (fromList [("nspname",String "e")])),("relname",String "f")])),("constraint__namespace",Object (fromList [("nspname",String "a")]))])+-- True+++class ToJSONCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r where+ toPairs :: r -> [Pair]++class FromJSONCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r where+ parseJSONCols :: Value -> Parser r++-- (:=)+--------------------------------------------------------------------------------+-- NonGeneric: (:=) и (:.)+--------------------------------------------------------------------------------+instance ToJSONCols ann 'NonGenericCase '[] (fld := ()) where+ toPairs _ = []++instance FromJSONCols ann 'NonGenericCase '[] (fld := ()) where+ parseJSONCols = pure $ pure (PgTag ())++instance (KnownSymNat sn, ToJSON t, Coercible v t)+ => ToJSONCols ann 'NonGenericCase '[ 'ColInfo sn t db fi ] (fld := v) where+ toPairs (PgTag v) = [Key.fromText (demote @(NameSymNat sn)) .= coerce @_ @t v]++instance+ (KnownSymNat sn, FromJSON tEff, Coercible t tEff)+ => FromJSONCols ann 'NonGenericCase '[ 'ColInfo sn tEff db fi ] (fld := t) where+ parseJSONCols = withObject "record" $ \obj -> do+ case KM.lookup (Key.fromText keyTxt) obj of+ Nothing -> fail ("missing key " ++ T.unpack keyTxt)+ Just v -> coerce <$> parseJSON @tEff v -- eff :: tEff+ where+ keyTxt = demote @(NameSymNat sn)++instance+ ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b+ , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols+ , ToJSONCols ann ca colsA a, ToJSONCols ann cb colsB b )+ => ToJSONCols ann 'NonGenericCase cols (a :. b) where+ toPairs (a :. b) = toPairs @ann @ca @colsA a <> toPairs @ann @cb @colsB b++instance+ ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b+ , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols+ , FromJSONCols ann ca colsA a, FromJSONCols ann cb colsB b)+ => FromJSONCols ann 'NonGenericCase cols (a :. b) where+ parseJSONCols v =+ (:.) <$> parseJSONCols @ann @ca @colsA v <*> parseJSONCols @ann @cb @colsB v++--------------------------------------------------------------------------------+-- Generic+-----------------------------------------------------------------------------+class GToJSONCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where+ gToPairs :: rep x -> [Pair]++class GFromJSONCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where+ gParseJSONCols :: Value -> Parser (rep x)++instance+ (Generic r, GToJSONCols ann cols (Rep r))+ => ToJSONCols ann 'GenericCase cols r where+ toPairs r = gToPairs @ann @cols (from r)++instance+ (Generic r, GFromJSONCols ann cols (Rep r))+ => FromJSONCols ann 'GenericCase cols r where+ parseJSONCols = fmap to . gParseJSONCols @ann @cols++-- D1/C1+instance GToJSONCols ann cols flds+ => GToJSONCols ann cols (D1 d (C1 c flds)) where+ gToPairs (M1 (M1 x)) = gToPairs @ann @cols x++instance GFromJSONCols ann cols flds+ => GFromJSONCols ann cols (D1 d (C1 c flds)) where+ gParseJSONCols = fmap (M1 . M1) . gParseJSONCols @ann @cols++-- (:*:)+instance+ ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols+ , GToJSONCols ann colsA a, GToJSONCols ann colsB b )+ => GToJSONCols ann cols (a :*: b) where+ gToPairs (a :*: b) = gToPairs @ann @colsA a <> gToPairs @ann @colsB b++instance+ ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols+ , GFromJSONCols ann colsA a, GFromJSONCols ann colsB b )+ => GFromJSONCols ann cols (a :*: b) where+ gParseJSONCols v =+ (:*:) <$> gParseJSONCols @ann @colsA v <*> gParseJSONCols @ann @colsB v++-- Rec0+instance (ToJSONCols ann 'NonGenericCase cols (fld := t))+ => GToJSONCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t))+ where+ gToPairs (M1 (K1 v)) = toPairs @ann @'NonGenericCase @cols (fld =: v)++instance (FromJSONCols ann 'NonGenericCase cols (fld := t))+ => GFromJSONCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where+ gParseJSONCols = fmap (M1 . K1 . unPgTag)+ . parseJSONCols @ann @'NonGenericCase @cols @(fld := t)++--------------------------------------------------------------------------------+-- ToRow / FromRow for PgTag ann r+--------------------------------------------------------------------------------+instance ToJSON (PgTag ann r) => ToField (PgTag (ann :: Ann) r) where+ toField = toJSONField++instance ToJSON (PgTag ann r) => ToField [PgTag (ann :: Ann) r] where+ toField = toJSONField++instance (FromJSON (PgTag ann r), Typeable ann, Typeable r)+ => FromField (PgTag (ann :: Ann) r) where+ fromField = fromJSONField++instance (FromJSON (PgTag ann r), Typeable ann, Typeable r)+ => FromField [PgTag (ann :: Ann) r] where+ fromField = fromJSONField++--------------------------------------------------------------------------------+-- ToRow / FromRow for PgTag ann r+--------------------------------------------------------------------------------+instance+ (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, ToRowCols ann colsCase cols r)+ => ToRow (PgTag ann r) where+ toRow (PgTag r) = toRowCols @ann @colsCase @cols r++instance+ (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromRowCols ann colsCase cols r)+ => FromRow (PgTag ann r) where+ fromRow = PgTag <$> fromRowCols @ann @colsCase @cols++-- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint")+-- >>> (r1 :: [PgTag AnnRel ( ("conkey" := Int16))]) <- query_ conn "select 1::int2"+-- >>> r1+-- [PgTag {unPgTag = PgTag {unPgTag = 1}}]++class ToRowCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r+ where+ toRowCols :: r -> [Action]++class FromRowCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r+ where+ fromRowCols :: RowParser r++--------------------------------------------------------------------------------+-- NonGeneric: (:=) and (:.)+--------------------------------------------------------------------------------+instance ToRowCols ann 'NonGenericCase '[] (fld := ()) where+ toRowCols _ = []++instance FromRowCols ann 'NonGenericCase '[] (fld := ()) where+ fromRowCols = pure (PgTag ())++instance (KnownSymNat sn, ToField t, Coercible v t)+ => ToRowCols ann 'NonGenericCase '[ 'ColInfo sn t db fi ] (fld := v) where+ toRowCols (PgTag v) = [toField (coerce @_ @t v)]++instance (FromField tEff, Coercible t tEff)+ => FromRowCols ann 'NonGenericCase '[ 'ColInfo sn tEff db fi ] (fld := t) where+ fromRowCols = coerce <$> field @tEff++instance+ ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b+ , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols+ , ToRowCols ann ca colsA a, ToRowCols ann cb colsB b )+ => ToRowCols ann 'NonGenericCase cols (a :. b) where+ toRowCols (a :. b) = toRowCols @ann @ca @colsA a <> toRowCols @ann @cb @colsB b++instance+ ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b+ , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols+ , FromRowCols ann ca colsA a, FromRowCols ann cb colsB b )+ => FromRowCols ann 'NonGenericCase cols (a :. b) where+ fromRowCols = (:.) <$> fromRowCols @ann @ca @colsA <*> fromRowCols @ann @cb @colsB++--------------------------------------------------------------------------------+-- Generic: through Rep r+--------------------------------------------------------------------------------++class GToRowCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where+ gToRowCols :: rep x -> [Action]++class GFromRowCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where+ gFromRowCols :: RowParser (rep x)++instance (Generic r, GToRowCols ann cols (Rep r))+ => ToRowCols (ann :: Ann) 'GenericCase cols r where+ toRowCols r = gToRowCols @ann @cols (from r)++instance (Generic r, GFromRowCols ann cols (Rep r))+ => FromRowCols ann 'GenericCase cols r where+ fromRowCols = to <$> gFromRowCols @ann @cols++instance GToRowCols ann cols flds+ => GToRowCols ann cols (D1 d (C1 c flds)) where+ gToRowCols (M1 (M1 x)) = gToRowCols @ann @cols x++instance GFromRowCols ann cols flds+ => GFromRowCols ann cols (D1 d (C1 c flds)) where+ gFromRowCols = fmap (M1 . M1) (gFromRowCols @ann @cols)++instance+ ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols+ , GToRowCols ann colsA a, GToRowCols ann colsB b )+ => GToRowCols ann cols (a :*: b) where+ gToRowCols (a :*: b) = gToRowCols @ann @colsA a <> gToRowCols @ann @colsB b++instance+ ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols+ , GFromRowCols ann colsA a, GFromRowCols ann colsB b )+ => GFromRowCols ann cols (a :*: b) where+ gFromRowCols = (:*:) <$> gFromRowCols @ann @colsA <*> gFromRowCols @ann @colsB++instance ToRowCols ann 'NonGenericCase cols (fld := t)+ => GToRowCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where+ gToRowCols (M1 (K1 v)) = toRowCols @ann @'NonGenericCase @cols (fld =: v)++instance+ FromRowCols ann 'NonGenericCase cols (fld := t)+ => GFromRowCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where+ gFromRowCols = M1 . K1 . unPgTag+ <$> fromRowCols @ann @'NonGenericCase @cols @(fld := t)++--------------------------------------------------------------------------------+-- CRecInfo+--------------------------------------------------------------------------------++data FieldInfo s = FieldInfo+ { fieldName :: s+ , fieldDbName :: s+ , fieldKind :: RecField' s (RecordInfo s) }+ deriving Show++data RecordInfo s = RecordInfo+ { tabName :: NameNS' s+ , fields :: [FieldInfo s] }+ deriving Show++class CRecInfo (ann :: Ann) (r :: Type) where+ getRecordInfo :: RecordInfo T.Text++class CRecInfoCols (ann :: Ann) (cols :: [ColInfo NameNSK]) where+ getFields :: [FieldInfo T.Text]++class CFldInfo (ann :: Ann) (fld :: RecField' Symbol NameNSK) t where+ getFldInfo :: RecField (RecordInfo T.Text)++-- instance (ann ~ 'Ann ren sch tab, SingI tab) => CRecInfo ann () where+-- getRecordInfo = RecordInfo (demote @tab) []++instance+ (ann ~ 'Ann ren sch d tab, SingI tab, cols ~ Cols ann r, CRecInfoCols ann cols)+ => CRecInfo ann r where+ getRecordInfo = RecordInfo (demote @tab) (getFields @ann @cols)++instance CRecInfoCols ann '[] where getFields = []++instance+ (KnownSymNat sn, KnownSymbol db, CFldInfo ann fi t, CRecInfoCols ann cols)+ => CRecInfoCols ann ('ColInfo sn t db fi ': cols) where+ getFields = FieldInfo+ { fieldName = demote @(NameSymNat sn)+ , fieldDbName = demote @db+ , fieldKind = getFldInfo @ann @fi @t } : getFields @ann @cols++instance ToStar fd => CFldInfo ann ('RFPlain fd) t where+ getFldInfo = RFPlain (demote @fd)++instance (ToStar fd, ToStar af, ToStar b) =>+ CFldInfo ann ('RFAggr fd af b) t where+ getFldInfo = RFAggr (demote @fd) (demote @af) (demote @b)++type family AnnRefTabDepth (ann :: Ann) refTab :: Ann where+ AnnRefTabDepth ('Ann ren sch d tab) refTab =+ 'Ann ren sch (DecDepth ('Ann ren sch d tab)) refTab++instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann fromTab)+ => CFldInfo ann ('RFToHere fromTab refs) [PgTag ann' r] where+ getFldInfo = RFToHere (getRecordInfo @ann' @r) (demote @refs)++instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann toTab)+ => CFldInfo ann ('RFFromHere toTab refs) (Maybe (PgTag ann' r)) where+ getFldInfo = RFFromHere (getRecordInfo @ann' @r) (demote @refs)++instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann toTab)+ => CFldInfo ann ('RFFromHere toTab refs) (PgTag ann' r) where+ getFldInfo = RFFromHere (getRecordInfo @ann' @r) (demote @refs)++--------------------------------------------------------------------------------+-- Helpers over Cols ann r+--------------------------------------------------------------------------------++type family ColDbName (c :: ColInfo p) :: Symbol where+ ColDbName ('ColInfo '(fld, idx) t db fi) = db++type family ColsDbNames (cols :: [ColInfo p]) :: [Symbol] where+ ColsDbNames '[] = '[]+ ColsDbNames (c ': cs) = ColDbName c ': ColsDbNames cs++--------------------------------------------------------------------------------+-- Plain fields (without relation fields)+--------------------------------------------------------------------------------++type family IsPlainRecField (fi :: RecField' Symbol NameNSK) :: Bool where+ IsPlainRecField ('RFToHere tab rs) = 'False+ IsPlainRecField ('RFFromHere tab rs) = 'False+ IsPlainRecField ('RFSelfRef tab rs) = 'False+ IsPlainRecField fi = 'True++type family AllPlainCols (cols :: [ColInfo NameNSK]) :: Bool where+ AllPlainCols '[] = 'True+ AllPlainCols ('ColInfo sn t db fi ': cs) = IsPlainRecField fi && AllPlainCols cs++-- | All fields are plain (no RFToHere/RFFromHere)+type family AllPlain (ann :: Ann) (r :: Type) :: Constraint where+ AllPlain ann r = Assert (AllPlainCols (Cols ann r))+ (TypeError+ ( Text "Not all fields in record are 'plain' (no relations allowed)."+ :$$: Text "Ann: " :<>: ShowType ann+ :$$: Text "Type: " :<>: ShowType r+ :$$: Text "Cols: " :<>: ShowType (Cols ann r) ))++--------------------------------------------------------------------------------+-- Type-level RecordInfo for Ann+--------------------------------------------------------------------------------+-- | Decrease relation-walk depth kept in 'Ann'.+-- When depth is exhausted, fail with a detailed type error instead of+-- potentially diverging in recursive type families/instances.+type family DecDepth (ann :: Ann) :: Nat where+ DecDepth ('Ann ren sch 0 tab) = TypeError+ ( Text "pg-schema: relation walk depth limit reached."+ :$$: Text ""+ :$$: Text "Ann: " :<>: ShowType ('Ann ren sch 0 tab)+ :$$: Text "Table: " :<>: ShowType tab+ :$$: Text ""+ :$$: Text "Likely reason:"+ :$$: Text " Recursive/self-referential tree (SelfRef or cycle) is deeper"+ :$$: Text " than annDepth in your Ann."+ :$$: Text ""+ :$$: Text "How to fix:"+ :$$: Text " 1) Increase annDepth in Ann;"+ :$$: Text " 2) Reduce recursion depth in selected/inserted shape;"+ :$$: Text " 3) For true graph cycles, use manual SQL." )+ DecDepth ('Ann _ _ d _) = d - 1++-- Type-level analogue of CFldInfo: take DB-level RecFieldK and Haskell type of field t+-- and build RecField' Symbol (RecordInfo Symbol) with TRecordInfo for children.+type family TFldInfo (ann :: Ann) (fi :: RecField' Symbol NameNSK) t+ :: RecField' Symbol (RecordInfo Symbol) where+ TFldInfo ann ('RFPlain fd) t = 'RFPlain fd+ TFldInfo ann ('RFAggr fd af b) t = 'RFAggr fd af b+ TFldInfo ann ('RFEmpty s) t = 'RFEmpty s+ TFldInfo ('Ann ren sch d tab) ('RFToHere (toTab :: NameNSK) refs)+ [PgTag ('Ann ren sch d' toTab) rChild] =+ 'RFToHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs+ TFldInfo ('Ann ren sch d tab) ('RFFromHere (toTab :: NameNSK) refs)+ (Maybe (PgTag ('Ann ren sch d' toTab) rChild)) =+ 'RFFromHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs+ TFldInfo ('Ann ren sch d tab) ('RFFromHere (toTab :: NameNSK) refs)+ (PgTag ('Ann ren sch d' toTab) rChild) =+ 'RFFromHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs+ TFldInfo ann fi t = TypeError+ ( Text "TFldInfo: unsupported RecField for Ann."+ :$$: Text " Ann: " :<>: ShowType ann+ :$$: Text " RecField: " :<>: ShowType fi+ :$$: Text " Haskell type: " :<>: ShowType t+ :$$: Text ""+ :$$: Text "Most likely TDBFieldInfo / ColFI produced a constructor"+ :$$: Text "that TFldInfo does not know how to map into RecordInfo." )++type family TRecordInfoCols (ann :: Ann) (cols :: [ColInfo NameNSK]) :: [FieldInfo Symbol] where+ TRecordInfoCols ann '[] = '[]+ TRecordInfoCols ann ('ColInfo sn t db fi ': cs) =+ 'FieldInfo (NameSymNat sn) db (TFldInfo ann fi t) ': TRecordInfoCols ann cs++type family TRecordInfo (ann :: Ann) (r :: Type) :: [FieldInfo Symbol] where+ TRecordInfo ann r = TRecordInfoCols ann (Cols ann r)++--------------------------------------------------------------------------------+-- Node-level checks for Mandatory / PK (analogue of CheckNodeAll*)+--------------------------------------------------------------------------------++-- | One-table check that all mandatory fields are present+-- rs: list of columns that are already "covered" (including those that come from Reference)+type family CheckAllMandatory (ann :: Ann) (rs :: [Symbol]) :: Constraint where+ CheckAllMandatory ('Ann ren sch d tab) rs = TE.Assert+ (SP.Null (RestMandatory sch tab rs))+ (TypeError+ ( Text "We can't insert data because not all mandatory fields are present."+ :$$: Text "Table: " :<>: ShowType tab+ :$$: Text "Missing mandatory fields: " :<>: ShowType (RestMandatory sch tab rs) ))++-- | One-table check that all mandatory fields are present+-- or all PK fields are present+type family CheckAllMandatoryOrHasPK (ann :: Ann) (rs :: [Symbol]) :: Constraint where+ CheckAllMandatoryOrHasPK ('Ann ren sch d tab) rs = TE.Assert+ ( SP.Null (RestMandatory sch tab rs)+ || SP.Null (RestPK sch tab rs) )+ (TypeError+ ( Text "We can't upsert data because for table " :<>: ShowType tab+ :$$: Text "either not all mandatory fields or not all PK fields are present."+ :$$: Text "Missing mandatory fields: " :<>: ShowType (RestMandatory sch tab rs)+ :$$: Text "Missing PK fields: " :<>: ShowType (RestPK sch tab rs) ))++genDefunSymbols [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasPK]++--------------------------------------------------------------------------------+-- Recursive AllMandatory / PK for tree (JSON insert / upsert)+--------------------------------------------------------------------------------+type family WalkLevelAnn+ (check :: Ann ~> [Symbol] ~> Constraint)+ (ann :: Ann) (fis :: [FieldInfo Symbol]) (rs :: [Symbol]) :: Constraint where+ WalkLevelAnn check ann '[] rs = SP.Apply (SP.Apply check ann) rs+ WalkLevelAnn check ann ('FieldInfo name db ('RFPlain fd) ': xs) rs =+ WalkLevelAnn check ann xs (db ': rs)+ WalkLevelAnn check ('Ann ren sch d tab)+ ('FieldInfo _ _ ('RFToHere ('RecordInfo childTab childFIs) refs) ': xs) rs =+ ( WalkLevelAnn check ('Ann ren sch d childTab) childFIs (SP.Map1 FromNameSym0 refs)+ , WalkLevelAnn check ('Ann ren sch d tab) xs rs )+ WalkLevelAnn check ann (_ ': xs) rs = WalkLevelAnn check ann xs rs++type family AllMandatoryTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])+ :: Constraint where+ AllMandatoryTree ann [r] rFlds = AllMandatoryTree ann r rFlds+ AllMandatoryTree ann r rFlds =+ WalkLevelAnn CheckAllMandatorySym0 ann (TRecordInfo ann r) rFlds++type family AllMandatoryOrHasPKTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])+ :: Constraint where+ AllMandatoryOrHasPKTree ann [r] rFlds = AllMandatoryOrHasPKTree ann r rFlds+ AllMandatoryOrHasPKTree ann r rFlds =+ WalkLevelAnn CheckAllMandatoryOrHasPKSym0 ann (TRecordInfo ann r) rFlds++--------------------------------------------------------------------------------+-- Returning tree must be subtree of input tree (with path)+--------------------------------------------------------------------------------++type family Snoc (p :: [k]) (x :: k) :: [k] where+ Snoc '[] x = '[x]+ Snoc (a ': as) x = a ': Snoc as x++type family FindChildAt (path :: [Symbol]) (db :: Symbol)+ (fisIn :: [FieldInfo Symbol]) :: [FieldInfo Symbol] where+ FindChildAt path db '[] = TypeError+ ( Text "Returning tree is not a subtree of input tree."+ :$$: Text "At path: " :<>: ShowType path+ :$$: Text "Missing branch (db name): " :<>: ShowType db )+ FindChildAt _ db ('FieldInfo _ db ('RFToHere ('RecordInfo _ fis) _) ': xs) = fis+ FindChildAt _ db ('FieldInfo _ db ('RFFromHere ('RecordInfo _ fis) _) ': xs) = fis+ FindChildAt path db (_ ': xs) = FindChildAt path db xs++type family CheckSubtreeAt (path :: [Symbol]) (fisIn :: [FieldInfo Symbol])+ (fisOut :: [FieldInfo Symbol]) :: Constraint where+ CheckSubtreeAt path fisIn '[] = ()+ CheckSubtreeAt path fisIn+ ('FieldInfo _ db ('RFToHere ('RecordInfo _ childFIsOut) _) ': xs) =+ ( CheckSubtreeAt (Snoc path db) (FindChildAt path db fisIn) childFIsOut+ , CheckSubtreeAt path fisIn xs )+ CheckSubtreeAt path fisIn+ ('FieldInfo _ db ('RFFromHere ('RecordInfo _ childFIsOut) _) ': xs) =+ ( CheckSubtreeAt (Snoc path db) (FindChildAt path db fisIn) childFIsOut+ , CheckSubtreeAt path fisIn xs )+ CheckSubtreeAt path fisIn (_ ': xs) = CheckSubtreeAt path fisIn xs++-- | Check that returning tree is a subtree of input tree+type family ReturningIsSubtree (ann :: Ann) (rIn :: Type) (rOut :: Type) :: Constraint where+ ReturningIsSubtree ann rIn rOut =+ CheckSubtreeAt '[] (TRecordInfo ann rIn) (TRecordInfo ann rOut)
+ src/PgSchema/DML.hs view
@@ -0,0 +1,141 @@+-- |+-- Module: PgSchema.DML+-- Copyright: (c) Dmitry Olshansky+-- License: BSD-3-Clause+-- Maintainer: olshanskydr@gmail.com, dima@typeable.io+-- Stability: experimental+--+-- = A module to generate and safely execute SQL statements.+--+-- Among @pg-schema@’s library modules, this is the one meant for ordinary application+-- imports for database access (alongside your generated schema module).+--+-- == TLDR; Example:+--+-- @+-- data Order = Order { num :: Text, createdAt :: Day, items :: [OrdPos] } deriving Generic+-- data OrdPos = OrdPos { id :: Int32, num :: Int32, article :: Article, price :: Double } deriving Generic+-- data Article = Article { id :: Int32, name :: Text } deriving Generic+-- type MyAnn tabName = 'Ann 5 CamelToSnake MySch ("dbSchema" ->> tabName)+-- ...+-- do+-- void $ insertJSON_ (MyAnn "orders") conn+-- [ "num" =: "num1" :. "ord__ord_pos" =:+-- [ "num" =: 1 :. "articleId" =: 42 :. "price" =: 10+-- , "num" =: 2 :. "articleId" =: 41 :. "price" =: 15 ] ]+--+-- (xs :: [Order]) <- selectSch (MyAnn "orders") conn $ qRoot do+-- qWhere $ "created_at" >? someDay+-- &&& pchild "ord__ord_pos" defTabParam+-- (pparent "ord_pos__article" $ "name" ~~? "%pencil%")+-- qOrderBy [descf "created_at", descf "num"]+-- qPath "ord__ord_pos" do+-- qWhere $ pparent "ord_pos__article" $ "name" ~~? "%pencil%"+-- qOrderBy [ascf "num"]+-- qLimit 20+-- @+--+-- Here we get all orders created after `someDay` that have positions with articles like "%pencil%",+-- and return only those order items that relate to "pencil", with article info.+--+-- The preceding 'insertJSON_' call inserts one root row (here an order) and nested+-- /child/ rows (here order positions) in a single database operation, again using+-- JSON internally. Child data is carried in list fields: the field’s name (after 'Renamer') names+-- the FK constraint in the database and thus selects the child table and link;+-- each list element supplies one child row’s columns, with nested lists for further+-- children in the same way. For strict inserts,+-- 'insertJSON' and 'insertJSON_' require every mandatory column at each node;+-- 'upsertJSON' / 'upsertJSON_' relax that so each row can be resolved by keys and+-- optional columns (see their Haddock). Plain 'insertSch' / 'insertSch_' follow the+-- same safety story for flat (non-tree) rows.+--+-- 'selectSch' decodes each row into a Haskell type @r@ whose fields describe the+-- root table columns and nested data for relations (multiple list-shaped children+-- and nested parents/'Maybe' as appropriate). The type drives the generated SQL+-- shape; monadic 'QueryParam' only adds what this call needs—filters, ordering on a+-- branch, limits, and so on.+--+-- We can use both 'GHC.Generics.Generic'-based and 'PgTag'-based ('(=:)') interfaces and mix them in any way.+--+-- All string literals at the type level are 'GHC.TypeLits.Symbol' thanks to @RequiredTypeArguments@.+-- Operations are safe when the live database schema matches the generated schema types.+--+-- The @INSERT@ and @SELECT@ shown here each run as a single, fast database round-trip (JSON inside PostgreSQL).+--+-- We use a 'Renamer' (e.g. 'CamelToSnake') to map Haskell field names to @snake_case@ in the database.+-- In conditions and 'QueryParams', column names are the original database names.+-- It can be changed in the future.+--+module PgSchema.DML+ (+ -- * DML+ -- ** Select+ -- *** Execute SQL+ selectSch, selectText, Selectable+ -- *** Monad to set Query Params+ , MonadQP, qpEmpty+ , qRoot, qPath, qWhere, qOrderBy, qDistinct, qDistinctOn, qLimit, qOffset+ -- **** Internals+ , QueryParam(..), CondWithPath(..), OrdWithPath(..), LimOffWithPath(..), DistWithPath(..)+ -- *** Conditions+ -- | Example: @"name" =? "John"@+ , (<?),(>?),(<=?),(>=?),(=?)+ -- | Example: @"name" ~~? "%joh%"@+ ,(~=?),(~~?)+ , (|||), (&&&), pnot, pnull, pin, pinArr+ , pparent, pchild, TabParam(..), defTabParam+ , pUnsafeCond+ , Cond(..), Cmp(..), BoolOp(..)+ , CondMonad, SomeToField(..), showCmp, tabPref, qual+ , CDBField, CDBValue, CDBFieldNullable, CRelDef+ -- *** Order By and others+ , ordf, ascf, descf, defLO, lo1+ , OrdDirection(..), OrdFld(..), Dist(..), LO(..)+ -- ** Plain Insert+ , insertSch, insertSch_, insertText, insertText_, AllPlain+ , InsertNonReturning, InsertReturning+ -- ** Update+ , updateByCond, updateByCond_, updateText, updateText_+ , UpdateReturning, UpdateNonReturning, CRecInfo(..)+ -- ** Tree-base Insert/Upsert+ , insertJSON, insertJSON_, upsertJSON, upsertJSON_, insertJSONText, insertJSONText_+ , TreeIn, TreeOut, AllMandatoryTree, AllMandatoryOrHasPKTree, TreeSch+ , InsertTreeNonReturning, InsertTreeReturning+ , UpsertTreeNonReturning, UpsertTreeReturning, TRecordInfo+ -- ** Delete+ , deleteByCond, deleteText+ -- * Types+ , Ann(..), ToStar+ -- ** Renamers+ , RenamerId, CamelToSnake, Renamer, ApplyRenamer+ -- ** PgTag types+ , type (:=), (=:), PgTag(..),+ -- | Re-export from postgresql-simple+ (:.)(..)+ -- ** Enum+ , PGEnum+ -- ** Aggregates+ , Aggr'(..), Aggr(..), AggrFun(..)+ -- ** Arrays+ , PgArr(..), pgArr', unPgArr'+ -- ** Conversion checks+ , CanConvert, CanConvert1, TypDef'(..)+ -- ** Other types+ , PgChar(..), PgOid(..)+ , NameNS'(..), type (->>), NameNSK, (->>)+ , TRelDef, RelDef'(..), RdFrom, RdTo, FdType, FdNullable, CTabDef(..)+ ) where+++import PgSchema.Ann+import PgSchema.DML.Select as S+import PgSchema.DML.Select.Types as S+import PgSchema.DML.Insert as I+import PgSchema.DML.Insert.Types as I+import PgSchema.DML.InsertJSON as I+import PgSchema.DML.Update as U+import PgSchema.DML.Delete as D+import PgSchema.Schema as S+import PgSchema.Types as T+import PgSchema.Utils.CamelToSnake+import PgSchema.Utils.Internal as T (ToStar)
+ src/PgSchema/DML/Delete.hs view
@@ -0,0 +1,35 @@+module PgSchema.DML.Delete where++import Data.String+import Data.Text as T+import PgSchema.DML.Select+import PgSchema.DML.Select.Types+import Database.PostgreSQL.Simple+import GHC.Int++import PgSchema.Schema+import PgSchema.Utils.Internal+import Data.Singletons+++-- | Delete records in table by condition.+--+deleteByCond :: forall sch t -> SingI t =>+ Connection -> Cond sch t -> IO (Int64, (Text,[SomeToField]))+deleteByCond sch t conn cond = traceShow' (q,ps)+ $ (,(q,ps)) <$> execute conn (fromString $ T.unpack q) ps+ where+ (q, ps) = deleteText @sch @t cond++-- | Construct SQL text for deleting records by condition.+--+deleteText :: forall sch t s. (IsString s, Monoid s, SingI t) =>+ Cond sch t -> (s, [SomeToField])+deleteText cond =+ ("delete from " <> tn <> " t0 " <> fromText whereTxt, condParams )+ where+ tn = fromText $ qualName $ demote @t+ (condTxt, condParams) = pgCond 0 cond+ whereTxt+ | T.null condTxt = mempty+ | otherwise = " where " <> condTxt
+ src/PgSchema/DML/Insert.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE KindSignatures #-}+module PgSchema.DML.Insert where++import Data.Bifunctor+import Data.String+import Data.Text as T+import Database.PostgreSQL.Simple+import GHC.Int+import PgSchema.Ann+import PgSchema.DML.Insert.Types+import PgSchema.Schema+import PgSchema.Types+import PgSchema.Utils.Internal+++-- | Insert records into a table.+-- You can request any subset of columns from the inserted row via the result type.+--+-- All mandatory fields having no defaults should be present.+--+insertSch+ :: forall ann -> forall r r'. InsertReturning ann r r'+ => Connection -> [r] -> IO ([r'], Text)+insertSch ann @r @r' conn = let sql = insertText ann @r @r' in+ trace' (T.unpack sql)+ $ fmap ((, sql) . fmap (unPgTag @ann @r'))+ . returning conn (fromString $ T.unpack sql)+ . fmap (PgTag @ann @r)++-- | Insert records into a table without @RETURNING@.+insertSch_ :: forall ann -> forall r. (InsertNonReturning ann r) =>+ Connection -> [r] -> IO (Int64, Text)+insertSch_ ann @r conn recs = let sql = insertText_ ann @r in do+ trace' (T.unpack sql)+ $ fmap (, sql)+ . executeMany conn (fromString $ T.unpack sql)+ . fmap (PgTag @ann @r) $ recs++-- | Construct SQL text for inserting records into a table and returning some fields.+insertText+ :: forall ann -> forall r r' s+ . (CRecInfo ann r, CRecInfo ann r', IsString s, Monoid s) => s+insertText ann @r @r'= insertText_ ann @r <> " returning " <> fs'+ where+ ri = getRecordInfo @ann @r'+ fs' = fromText $ T.intercalate "," [ fi.fieldDbName | fi <- ri.fields]++-- | Construct SQL text for inserting records into a table without @RETURNING@.+insertText_ :: forall ann -> forall r s. (IsString s, Monoid s) =>+ CRecInfo ann r => s+insertText_ ann @r = "insert into " <> tn <> "(" <> fs <> ") values (" <> qs <> ")"+ where+ ri = getRecordInfo @ann @r+ (fs,qs) = bimap inter inter $ unzip [ (fi.fieldDbName,"?") | fi <- ri.fields]+ tn = fromText $ qualName ri.tabName+ inter = fromText . T.intercalate ","
+ src/PgSchema/DML/Insert/Types.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE UndecidableInstances #-}+module PgSchema.DML.Insert.Types where++import Data.Aeson+import Data.Typeable+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.ToRow+import PgSchema.Ann+import PgSchema.Types+import PgSchema.Schema++--------------------------------------------------------------------------------+-- Plain Insert / Upsert / Update+--------------------------------------------------------------------------------++type PlainIn ann r = (CRecInfo ann r, AllPlain ann r, ToRow (PgTag ann r))++type PlainOut ann r' = (CRecInfo ann r', AllPlain ann r', FromRow (PgTag ann r'))++-- | Plain insert without @RETURNING@.+-- Check that all fields belong to the root table and all mandatory fields are present.+type InsertNonReturning ann r =+ (PlainIn ann r, CheckAllMandatory ann (ColsDbNames (Cols ann r)))++-- | Plain insert with @RETURNING@.+-- Check that all inserted and returned fields belong to the root table+-- and all mandatory fields are present.+type InsertReturning ann r r' = (InsertNonReturning ann r, PlainOut ann r')++-- | Plain update with @RETURNING@.+-- Check that all updated and returned fields belong to the root table.+type UpdateReturning ann r r' = (UpdateNonReturning ann r, PlainOut ann r')++-- | Plain update without @RETURNING@.+-- Check that all updated fields belong to the root table.+type UpdateNonReturning ann r = PlainIn ann r++type TreeSch ann = CSchema (AnnSch ann)++type TreeIn ann r = (CRecInfo ann r, ToJSON (PgTag ann r))++type TreeOut ann r' = (CRecInfo ann r', FromJSON (PgTag ann r'),+ Typeable ann, Typeable r')++-- | Insert tree without @RETURNING@.+--+-- Check that all mandatory fields are present in all tables in tree.+-- Reference fields in the child tables are not checked - they are inserted automatically.+type InsertTreeNonReturning ann r =+ (TreeSch ann, TreeIn ann r, AllMandatoryTree ann r '[])++-- | Insert tree with @RETURNING@.+--+-- Check that all mandatory fields are present in all tables in tree.+-- Reference fields in the child tables are not checked - they are inserted automatically.+--+-- It also checks that we get returnings only from the tables we inserted into.+type InsertTreeReturning ann r r' =+ ( InsertTreeNonReturning ann r, TreeOut ann r', ReturningIsSubtree ann r r' )++-- | Upsert tree without @RETURNING@.+--+-- Check that all mandatory fields or primary keys are present in all tables in tree.+-- Reference fields in the child tables are not checked - they are inserted automatically.+type UpsertTreeNonReturning ann r =+ (TreeSch ann, TreeIn ann r, AllMandatoryOrHasPKTree ann r '[])++-- | Upsert tree with @RETURNING@.+--+-- Check that all mandatory fields or primary keys are present in all tables in tree.+-- Reference fields in the child tables are not checked - they are inserted automatically.+--+-- It also checks that we get returnings only from the tables we upserted into.+type UpsertTreeReturning ann r r' =+ ( UpsertTreeNonReturning ann r, TreeOut ann r', ReturningIsSubtree ann r r' )
+ src/PgSchema/DML/InsertJSON.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE OverloadedRecordDot #-}+module PgSchema.DML.InsertJSON+ ( insertJSON, insertJSON_, upsertJSON, upsertJSON_+ , insertJSONText, insertJSONText_ ) where++import Control.Monad+import Control.Monad.RWS+import Data.Aeson as A+import Data.ByteString.Lazy.Char8 qualified as BSL+import Data.Bifunctor+import Data.Foldable as F+import Data.Function+import Data.Functor+import Data.List as L+import Data.Map as M hiding (mapMaybe)+import Data.Maybe+import Data.Text as T hiding (any)+import Data.Traversable+import PgSchema.Ann+import PgSchema.DML.Insert.Types+import Database.PostgreSQL.Simple+import PgSchema.Schema+import PgSchema.Types+import Data.String+import GHC.Int+import PgSchema.Utils.Internal+import Prelude as P+++-- | Insert records into a table and its children using JSON data internally.+--+-- Like 'upsertJSON', but requires all mandatory columns at every node (insert-only constraint).++insertJSON+ :: forall ann -> forall r r'. InsertTreeReturning ann r r'+ => Connection -> [r] -> IO ([r'], Text)+insertJSON ann @r @r' = insertJSONImpl ann @r @r'++-- | Like 'insertJSON', but does not return rows.+--+insertJSON_+ :: forall ann -> forall r. InsertTreeNonReturning ann r+ => Connection -> [r] -> IO Text+insertJSON_ ann @r = insertJSONImpl_ ann @r++-- | Upsert a forest of rows into the root table and its /child/ tables in one+-- round-trip, using JSON inside PostgreSQL (same pipeline as 'insertJSON').+--+-- __Input shape (@r@):__ a record tree that may contain the root table’s columns+-- and nested /child/ branches (one-to-many from the root downward). There are no+-- nested /parent/ branches: parent keys are implied by the tree you send, not by+-- embedding parent rows inside children.+--+-- __Output shape (@r'@):__ a record tree whose graph of nested tables is a+-- /subgraph/ of the input: the same tables can appear, but you choose which+-- columns (and which levels) appear in the result—whatever is available through+-- the generated @RETURNING@/result projection. Field sets may differ from @r@;+-- relation structure cannot grow beyond what you sent in.+--+-- __What to supply at each node:__ at every level, each row must either include+-- all mandatory columns (for columns that are mandatory in the schema /sense of+-- this API/) or, alternatively, enough primary-key columns to identify an existing+-- row. Foreign-key columns that are filled in by the parent level (for example+-- after an auto-generated id on insert) do /not/ need to be present on the child+-- payload.+--+-- __Insert vs update vs upsert per row:__ the engine picks one of @INSERT@,+-- @UPDATE@, or @UPSERT@ from the keys and mandatory fields you provide:+--+-- * all mandatory fields present and /no/ primary key → @INSERT@+-- * primary key present, not all mandatory fields → @UPDATE@+-- * primary key present /and/ all mandatory fields → @UPSERT@+--+-- 'insertJSON' is the same execution path but adds a stricter type-level+-- constraint: /every/ mandatory field must be present (pure inserts). 'upsertJSON'+-- relaxes that so updates and upserts are expressible as in the rules above.+upsertJSON+ :: forall ann -> forall r r'. UpsertTreeReturning ann r r'+ => Connection -> [r] -> IO ([r'], Text)+upsertJSON ann @r @r' = insertJSONImpl ann @r @r'++-- | Like 'upsertJSON', but does not return rows.+--+upsertJSON_+ :: forall ann -> forall r. UpsertTreeNonReturning ann r+ => Connection -> [r] -> IO Text+upsertJSON_ ann @r = insertJSONImpl_ ann @r++insertJSONImpl+ :: forall ann -> forall r r'. (TreeSch ann, TreeIn ann r, TreeOut ann r')+ => Connection -> [r] -> IO ([r'], Text)+insertJSONImpl ann @r @r' conn rs = withTransactionIfNot conn do+ let sql' = T.unpack sql in trace' sql' $ void $ execute_ conn $ fromString sql'+ [Only res] <- let q = "select pg_temp.__ins(?)" in+ traceShow' q+ $ trace' (BSL.unpack $ A.encode (PgTag @ann @r <$> rs))+ $ query conn q $ Only $ PgTag @ann @r <$> rs+ void $ execute_ conn "drop function pg_temp.__ins"+ pure (unPgTag @ann @r' <$> res, sql)+ where+ sql = insertJSONText ann @r @r'++withTransactionIfNot :: Connection -> IO a -> IO a+withTransactionIfNot conn act = do+ isInTrans <- any (isJust @Int64 . fromOnly)+ <$> query_ conn "SELECT txid_current_if_assigned()"+ (if isInTrans then id else withTransaction conn) act++insertJSONImpl_+ :: forall ann -> forall r. (TreeSch ann, TreeIn ann r)+ => Connection -> [r] -> IO Text+insertJSONImpl_ ann @r conn rs = withTransactionIfNot conn do+ void $ trace' (T.unpack sql) $ execute_ conn $ fromString $ T.unpack sql+ void $ execute conn "call pg_temp.__ins(?)" $ Only $ PgTag @ann @r <$> rs+ sql <$ execute_ conn "drop procedure pg_temp.__ins"+ where+ sql = insertJSONText_ ann @r++insertJSONText_ :: forall ann -> forall r s.+ (IsString s, Monoid s, Ord s, TreeSch ann, CRecInfo ann r) => s+insertJSONText_ ann @r = insertJSONText' (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+ (getRecordInfo @ann @r) []++insertJSONText :: forall ann -> forall r r'.+ ( TreeSch ann, CRecInfo ann r, CRecInfo ann r'+ , IsString s, Monoid s, Ord s ) => s+insertJSONText ann @r @r' =+ insertJSONText' (typDefMap @(AnnSch ann)) (tabInfoMap @(AnnSch ann))+ (getRecordInfo @ann @r) (getRecordInfo @ann @r').fields++insertJSONText'+ :: forall s. (IsString s, Monoid s, Ord s)+ => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text -> [FieldInfo Text] -> s+insertJSONText' mapTypes mapTabs ir qfs = unlines'+ [ maybe+ "create or replace procedure pg_temp.__ins(data_0 jsonb) as $$"+ (const "create or replace function pg_temp.__ins(data_0 jsonb) returns jsonb as $$")+ mbRes+ , "declare"+ , unlines' $ (" " <>) <$> decl+ , "begin"+ , unlines' body+ , maybe "" (\r ->" return to_jsonb(" <> r <> ");") mbRes+ , "end; "+ , "$$ language plpgsql;" ]+ where+ (mbRes, (decl, body)) =+ evalRWS (insertJSONTextM mapTypes mapTabs ir qfs [] []) (" ",0) 0++type MonadInsert s = RWS (s, Int) ([s],[s]) Int+-- R: (leading spaces to format code, number of table in tree)+-- W: (lines of declarations, lines of function body)+-- S: maximum number of table in tree "in use"++data OP = INS | UPD | UPS deriving (Eq, Show)++data Field v = Field+ { jsonName :: Text+ , dbName :: Text+ , info :: v }+ deriving (Eq, Show)++insertJSONTextM+ :: forall s. (IsString s, Monoid s, Ord s)+ => M.Map NameNS TypDef -> M.Map NameNS TabInfo -> RecordInfo Text+ -> [FieldInfo Text] -> [s] -> [s] -> MonadInsert s (Maybe s)+insertJSONTextM mapTypes mapTabs ri qfs fromFields toVars = do+ (spaces, n) <- ask+ let+ sn = show' n+ dataN = "data_" <> sn+ rowN = "row_" <> sn+ mbArrN = ("arr_" <> sn) <$ guard (not $ P.null qfs)+ decs = (if n == 0 then P.id else (dataN <> " jsonb;" :))+ [rowN <> " record;"]+ <> foldMap (pure . (<> " jsonb[];")) mbArrN <> qretDecls+ qretDecls = qretPairs <&> \(fld, typ) -> fld <> sn <> " " <> typ <> "; "+ initArray = foldMap (pure . (<> ":= '{}';")) mbArrN+ startLoop =+ ["for " <> rowN <> " in select * from jsonb_array_elements("+ <> dataN <> ")", "loop"]+ (ins, op) = case mbKeyMand of+ Just (pk, mflds)+ | not $ P.null $ mflds L.\\ (fromFields <> (fst <$> plains)) ->+ (addSemiColon (upd0 <> rets), UPD)+ | P.null $ pk L.\\ (fromFields <> (fst <$> plainsPK)) -> (ups0 pk, UPS)+ _ -> (addSemiColon (ins0 <> rets), INS)+ where+ srcFlds = fromFields <> (fst <$> plains)+ srcVars = toVars <> (jsonFld <$> iplains)+ srcMap = M.fromList $ P.zip srcFlds srcVars+ mbSetVars+ | P.null (qretFlds L.\\ srcFlds) = Just+ $ catMaybes $ P.zipWith (\fld var ->+ (\srcVar -> var <> " := " <> srcVar <> ";")+ <$> srcMap M.!? fld) qretFlds qretVars+ | otherwise = Nothing+ ins0 =+ [ " insert into " <> qualTabName <> "(" <> intercalate' ", " srcFlds <> ")"+ , " values (" <> intercalate' ", " srcVars <> ")"]+ sWhere = "where " <> intercalate' " and "+ ( L.zipWith nameVal fromFields toVars <> (uncurry nameVal <$> plainsPK))+ upd0 =+ [ " update " <> qualTabName+ , " set " <> intercalate' ", " (uncurry nameVal <$> plains)+ , " " <> sWhere]+ ups0 pk+ | L.null plainsOthers = case mbSetVars of+ Just [] -> addSemiColon ins0+ Just xs -> ins0 <> [ " on conflict do nothing;"]+ <> [" " <> intercalate' " " xs]+ Nothing -> ins0 <> addSemiColon ([ " on conflict do nothing"] <> rets)+ <> [" if not found then"+ , " select " <> intercalate' ", " qretFlds <> " into " <> intercalate' ", " qretVars+ , " from " <> qualTabName+ , " " <> sWhere <> ";"+ , " end if;"]+ | L.null pk = addSemiColon ins0 -- support for tables without PK+ | otherwise = addSemiColon $ ins0+ <> [ " on conflict (" <> intercalate' ", " pk <> ")"+ , " do update set " <> intercalate' ", " (plainsOthers <&>+ \(name, _) -> name <> " = " <> "EXCLUDED." <> name) ]+ <> rets+ qretVars = (<> sn) <$> qretFlds+ plains = iplains <&> \ip -> (fromText ip.dbName, jsonFld ip)+ (plainsPK, plainsOthers) = L.partition ((`L.elem` foldMap fst mbKeyMand) . fst) plains+ jsonFld ip = case mapTypes M.!? ip.info.fdType of+ Just (TypDef "A" (Just t) _) ->+ "case when jsonb_typeof(" <> rowN <> ".value->'" <> fromText ip.jsonName <> "') = 'array'"+ <> " then (select coalesce(array_agg(__x)::" <> fromText (qualName t) <> "[], '{}')"+ <> " from jsonb_array_elements_text(" <> rowN <> ".value->'" <> fromText ip.jsonName <> "') __x) else null end"+ _ ->+ "(" <> rowN <> ".value->>'" <> fromText ip.jsonName <> "')::"+ <> fromText (qualName ip.info.fdType)+ rets+ | noRets = []+ | otherwise = [" returning " <> intercalate' ", " qretFlds+ <> " into " <> intercalate' ", " qretVars]+ endLoop = "end loop;"+ processChildren = do+ (spaces', _) <- ask+ (mapMaybe sequenceA -> arrs) <- for ichildren \(child, childRi) -> do+ modify (+1)+ n' <- get+ tell (mempty, pure $ spaces' <> "data_" <> show' n' <> " := "+ <> rowN <> ".value->'" <> fromText child.jsonName <> "';")+ let+ qfs' = foldMap ((.fields) . snd)+ $ L.find (\(qc, _) -> qc.jsonName == child.jsonName) qchildren+ mbArr <- local (second $ const n') $ insertJSONTextM mapTypes mapTabs+ childRi qfs' (fromText . (.fromName) <$> child.info)+ ((<> sn) . fromText . (.toName) <$> child.info)+ pure (fromText child.jsonName, mbArr)+ let+ appendArray = foldMap (\arrN -> pure $ arrN <> ":= array_append("+ <> arrN <> ", jsonb_build_object(" <> jsonFlds <> "));") mbArrN+ where+ jsonFlds = intercalate' ", "+ $ (qplains <&> \qp -> "'" <> fromText qp.jsonName+ <> "', " <> fromText qp.dbName <> sn)+ <> (arrs <&> \(jsonN, arr) -> "'" <> jsonN <> "', to_jsonb(" <> arr <> ")")+ tell (mempty, fmap (spaces' <>) appendArray)+ tell (decs, fmap (spaces <>) $ initArray <> startLoop <> ins)+ case op of+ UPD -> do+ tell (mempty, pure $ spaces <> " if found then")+ local (first (" " <>)) processChildren+ tell (mempty, pure $ spaces <> " end if;")+ _ -> local (first (" " <>)) processChildren+ tell (mempty, pure $ spaces <> endLoop)+ pure mbArrN+ where+ splitFields = P.foldr (\fi -> case fi.fieldKind of+ (RFPlain fd) -> first (Field fi.fieldName fi.fieldDbName fd :)+ (RFToHere ri' refs) -> second ((Field fi.fieldName fi.fieldDbName refs, ri') :)+ _ -> P.id) mempty+ (iplains, ichildren) = splitFields ri.fields+ (qplains, qchildren) = splitFields qfs+ mbKeyMand = mapTabs M.!? ri.tabName <&> ((,)+ <$> fmap fromText . (.tiDef.tdKey)+ <*> fmap fromText . M.keys+ . M.filter (\fd -> not $ fd.fdNullable || fd.fdHasDefault) . (.tiFlds))+ qualTabName = fromText (qualName ri.tabName)+ qcFlds = fmap ((,) <$> (.toName) <*> qualName . (.toDef.fdType))+ $ nubBy ((==) `on` (.toName)) $ ichildren >>= (\x -> (fst x).info)+ qpFlds = qplains <&> \p -> (p.dbName, qualName p.info.fdType)+ qretPairs = fmap (bimap fromText fromText)+ $ nubBy ((==) `on` fst) $ qcFlds <> qpFlds+ nameVal name val = name <> " = " <> val+ noRets = P.null qplains && P.null ichildren+ qretFlds = fst <$> qretPairs+ addSemiColon = \case+ [] -> []+ [x] -> [x <> ";"]+ (x:xs) -> x : addSemiColon xs
+ src/PgSchema/DML/Select.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DerivingVia #-}+module PgSchema.DML.Select where++import Control.Monad.RWS+import Control.Monad+import Data.Bifunctor+import Data.Foldable as F+import Data.Functor+import Data.List as L+import Data.List.NonEmpty as NE+import Data.Maybe+import Data.Monoid+import Data.Singletons+import Data.String+import Data.Text as T+import Data.Tuple+import PgSchema.DML.Select.Types+import PgSchema.Ann+import Database.PostgreSQL.Simple hiding(In(..))+import Database.PostgreSQL.Simple.Types(PGArray(..))+import PgSchema.Schema+import GHC.Generics+import GHC.TypeLits+import PgSchema.Types+import PgSchema.Utils.Internal+import PgSchema.Utils.TF (Snd)+import Prelude as P+++data QueryRead sch t = QueryRead+ { qrCurrTabNum :: Int+ , qrPath :: [Text]+ , qrParam :: QueryParam sch t }++data ParentInfo = ParentInfo+ { piRelDbName :: Text+ , piFromNum :: Int+ , piToNum :: Int+ , piParentTab :: NameNS+ , piRefs :: [Ref' Text]+ , piPath :: [Text] }+ deriving Show++data QueryState = QueryState+ { qsLastTabNum :: Int+ , qsParents :: [ParentInfo] }+ deriving Show++type MonadQuery sch t m = (MonadRWS (QueryRead sch t) [SomeToField] QueryState m)++type Selectable ann r = (CRecInfo ann r, FromRow (PgTag ann r))++-- | Run a single @SELECT@ for root table @tab@ (see annotation @ann@ with schema+-- @sch@ and 'Renamer' @ren@) and decode rows into @[r]@, also returning the SQL+-- text and bind parameters (for tracing or debugging).+--+-- The desired result type @r@ /fixes the shape/ of each row: typically a record+-- with columns of the root table and nested Haskell values for relations along the+-- schema graph. There may be several /child/-side fields (often lists of nested+-- records) and several /parent/-side fields (nested records; wrapped in 'Maybe'+-- when the foreign-key side you join from allows NULL).+--+-- What actually appears in the generated SQL beyond that shape is controlled by+-- the 'QueryParam': filters, which paths are traversed, ordering on a branch+-- (e.g. child rows sorted by their position number), limits, and similar options.+-- You only configure in 'QueryParam' what you need for this query—not every+-- possible relation field in @r@.+--+-- Build 'QueryParam' with the 'MonadQP' API.+--+selectSch :: forall ann -> forall r. (Selectable ann r, ann ~ 'Ann ren sch d tab)+ => Connection -> QueryParam sch tab -> IO ([r], (Text,[SomeToField]))+selectSch ann @r conn (selectText ann @r -> (sql,fs)) =+ trace' ("\n\n" <> T.unpack sql <> "\n\n" <> P.show fs <> "\n\n")+ $ (,(sql,fs)) . fmap (unPgTag @ann @r) <$> query conn (fromString $ T.unpack sql) fs++-- | Return the generated @SELECT@ SQL text (and bind parameters), e.g. for debugging.+selectText :: forall ann -> forall r. (CRecInfo ann r, ann ~ 'Ann ren sch d tab)+ => QueryParam sch tab -> (Text,[SomeToField])+selectText ann @r qp = evalRWS (selectM "" (getRecordInfo @ann @r)) (qr0 qp) qs0++qr0 :: QueryParam sch tab -> QueryRead sch tab+qr0 qrParam = QueryRead+ { qrCurrTabNum = 0 , qrPath = [] , qrParam }++qs0 :: QueryState+qs0 = QueryState { qsLastTabNum = 0, qsParents = [] }++two :: (a,b,c) -> (a,b)+two (a,b,_) = (a,b)++third :: (a,b,c) -> c+third (_,_,c) = c++jsonPairing :: [(Text, Text)] -> Text+jsonPairing fs = "jsonb_build_object(" <> T.intercalate "," pairs <> ")"+ where+ pairs = mapMaybe (\(a,b) -> Just $ "'" <> b <> "'," <> a) fs++newtype TextI (s::Symbol) = TextI { unTextI :: Text}++instance KnownSymbol s => Semigroup (TextI s) where+ TextI a <> TextI b =+ TextI $ T.intercalate (demote @s) $ L.filter (not . T.null) [a,b]++instance KnownSymbol s => Monoid (TextI s) where mempty = TextI mempty++selectM :: MonadQuery sch t m => Text -> RecordInfo Text -> m Text+selectM refTxt ri = do+ QueryRead {..} <- ask+ (fmap two -> flds) <- traverse fieldM ri.fields+ -- qsParents are collected "in depth" (it is ok for joins etc) but in reverse order+ parents <- gets+ $ fmap (\p -> p { piPath = L.reverse p.piPath}) . L.reverse . qsParents+ let+ basePath = L.reverse qrPath+ (unTextI -> condText, condPars) = F.fold $ L.reverse+ $ mapMaybe (\(CondWithPath @path cond) -> let p = demote @path in+ if+ | not (basePath `L.isPrefixOf` p) -> Nothing+ | p == basePath -> Just $ first TextI $ pgCond qrCurrTabNum cond+ | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+ <&> \pari -> first (TextI @" and ") $ pgCond pari.piToNum cond+ ) qrParam.qpConds+ (unTextI -> ordText, ordPars) = F.fold $ L.reverse+ $ mapMaybe (\(OrdWithPath @path ord) -> let p = demote @path in+ if+ | not (basePath `L.isPrefixOf` p) -> Nothing+ | p == basePath -> Just $ pgOrd qrCurrTabNum ord+ | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+ <&> \pari -> pgOrd pari.piToNum ord+ ) qrParam.qpOrds+ (distTexts, distPars) = F.fold $ L.reverse+ $ mapMaybe (\(DistWithPath @path dist) -> let p = demote @path in+ if+ | not (basePath `L.isPrefixOf` p) -> Nothing+ | p == basePath -> Just $ pgDist qrCurrTabNum dist+ | otherwise -> L.find ((p ==) . (basePath <>) . (.piPath)) parents+ <&> \pari -> pgDist pari.piToNum dist+ ) qrParam.qpDistinct+ sel+ | L.null basePath =+ T.intercalate "," $ L.map (\(a,b) -> a <> " \"" <> b <> "\"") flds+ | otherwise = jsonPairing flds+ whereText = let conds = L.filter (not . T.null) [refTxt, condText] in+ if L.null conds then mempty else " where " <> T.intercalate " and " conds+ orderText+ | T.null ordText && T.null distTexts.orderBy.unTextI = ""+ | otherwise = " order by " <> T.intercalate ","+ (L.filter (not . T.null) [distTexts.orderBy.unTextI, ordText])+ distinctText+ | distTexts.distinct.getAny && T.null distTexts.distinctOn.unTextI = " distinct "+ | T.null distTexts.distinctOn.unTextI = ""+ | otherwise = " distinct on (" <> distTexts.distinctOn.unTextI <> ") "+ qsLimOff = loByPath (L.reverse qrPath) $ qpLOs qrParam+ groupByText+ | P.null aggrs || P.null others = ""+ | otherwise = " group by " <> T.intercalate ","+ (L.nub $ others >>= \fi -> case fi.fieldKind of+ RFPlain{} -> [fi.fieldDbName]+ RFToHere _ refs -> refs <&> \ref -> ref.toName+ RFFromHere _ refs -> refs <&> \ref -> ref.fromName+ _ -> [])+ where+ (aggrs, others) = L.partition+ (\fld -> case fld.fieldKind of { RFAggr{} -> True; _ -> False })+ ri.fields+ tell $ distPars <> condPars <> distPars <> ordPars+ pure $ "select "+ <> distinctText+ <> sel+ <> " from " <> qualName ri.tabName <> " t" <> show' qrCurrTabNum+ <> " " <> T.unwords (joinText <$> trace' (show' parents) parents)+ <> whereText+ <> groupByText+ <> orderText+ <> qsLimOff++-- | SQL text for the column expression, result alias, and emptiness-test expression+-- (non-obvious for nested relation fields).+fieldM :: MonadQuery sch tab m => FieldInfo Text -> m (Text, Text, Text)+fieldM fi = case fi.fieldKind of+ RFEmpty s -> pure ("null", s, "true")+ RFSelfRef{} -> error "Impossible: RFSelfRef should be changed to RFFromHere or RFToHere"+ RFPlain {} -> do+ n <- asks qrCurrTabNum+ let val = "t" <> show' n <> "." <> fi.fieldDbName+ pure (val, fi.fieldName, val <> " is null")+ RFAggr _ (T.drop 1 . T.toLower . T.show -> fname) _ -> do+ n <- asks qrCurrTabNum+ let val = fname <> "(" <> "t" <> show' n <> "." <> fi.fieldDbName <> ")"+ pure case fname of+ "count" -> ("count(*)", fi.fieldName, " false")+ _ -> (val, fi.fieldName, val <> " is null")+ RFFromHere ri refs -> do+ QueryRead {..} <- ask+ modify \QueryState{qsLastTabNum = (+1) -> n2, qsParents} -> QueryState+ { qsLastTabNum = n2+ -- , qsJoins = joinText qrCurrTabNum n2 : qsJoins+ , qsParents = ParentInfo+ { piRelDbName = fi.fieldDbName+ , piFromNum = qrCurrTabNum+ , piToNum = n2+ , piParentTab = ri.tabName+ , piRefs = refs+ , piPath = fi.fieldDbName : qrPath } : qsParents }+ n2 <- gets qsLastTabNum+ (flds, pars) <- listen $ local+ (\qr -> qr{ qrCurrTabNum = n2, qrPath = fi.fieldDbName : qrPath })+ $ traverse fieldM ri.fields+ val <- if L.any (fdNullable . fromDef) refs+ then do+ tell pars+ pure $ "case when " <> T.intercalate " and " (third <$> flds)+ <> " then null else " <> jsonPairing (two <$> flds) <> " end"+ else pure $ jsonPairing $ two <$> flds+ pure (val, fi.fieldName, val <> " is null")+ RFToHere ri refs -> do+ QueryRead{..} <- ask+ QueryState {qsLastTabNum = (+1) -> tabNum, qsParents} <- get+ modify (const $ QueryState tabNum [])+ selText <- local+ (\qr -> qr { qrCurrTabNum = tabNum, qrPath = fi.fieldDbName : qrPath })+ $ selectM (refCond tabNum qrCurrTabNum refs) ri+ modify (\qs -> qs { qsParents = qsParents })+ let+ val = "array(" <> selText <> ")"+ pure ("array_to_json(" <> val <> ")", fi.fieldName, val <> " = '{}'")++joinText :: ParentInfo -> Text+joinText ParentInfo{..} =+ outer <> "join " <> qualName piParentTab <> " t" <> show' piToNum+ <> " on " <> refCond piFromNum piToNum piRefs+ where+ outer+ | hasNullableRefs piRefs = "left outer "+ | otherwise = ""++refCond :: Int -> Int -> [Ref] -> Text+refCond nFrom nTo = T.intercalate " and " . fmap compFlds+ where+ compFlds Ref {fromName, toName} =+ fldt nFrom fromName <> "=" <> fldt nTo toName+ where+ fldt n = (("t" <> show' n <> ".") <>)++withLOWithPath+ :: forall sch t r. (LO -> r) -> [Text] -> LimOffWithPath sch t -> Maybe r+withLOWithPath f p (LimOffWithPath @p lo) =+ guard (p == demote @p) >> pure (f lo)++withLOsWithPath+ :: forall sch t r. (LO -> r) -> [Text] -> [LimOffWithPath sch t] -> Maybe r+withLOsWithPath f p = join . L.find isJust . L.map (withLOWithPath f p)++lowp :: forall sch t. forall (path::[Symbol]) ->+ (ToStar path, TabPath sch t path+ , Snd (TabOnPath2 sch t path) ~ RelMany) => LO -> LimOffWithPath sch t+lowp p = LimOffWithPath @p++rootLO :: forall sch t. LO -> LimOffWithPath sch t+rootLO = lowp []++convLO :: LO -> Text+convLO (LO ml mo) =+ maybe "" ((" limit " <>) . show') ml+ <> maybe "" ((" offset " <>) . show') mo++loByPath :: forall sch t. [Text] -> [LimOffWithPath sch t] -> Text+loByPath p = fromMaybe mempty . withLOsWithPath convLO p++runCond :: Int -> CondMonad a -> (a,[SomeToField])+runCond n x = evalRWS x ("q", pure n) 0++tabPref :: CondMonad Text+tabPref = asks \case+ (_, n :| []) -> "t" <> show' n+ (p, n :| (np : _)) -> "t" <> show' np <> p <> show' n++qual :: forall (fld :: Symbol). ToStar fld => CondMonad Text+qual = tabPref <&> (<> "." <> (demote @fld))++--+convCond :: forall sch t . Cond sch t -> CondMonad Text+convCond = \case+ EmptyCond -> pure mempty+ Cmp @n cmp v -> do+ tell [SomeToField v]+ qual @n <&> (<> " " <> showCmp cmp <> " ?")+ In @n (NE.toList -> vs) -> do+ tell [SomeToField $ PGArray vs]+ qual @n <&> (<> " = any(?::" <> qualName (getFldDef @sch @t @n).fdType <> "[])")+ InArr @n vs -> do+ tell [SomeToField $ PGArray vs]+ qual @n <&> (<> " = any(?::" <> qualName (getFldDef @sch @t @n).fdType <> "[])")+ Null @n -> qual @n <&> (<> " is null")+ Not c -> getNot <$> convCond c+ BoolOp bo c1 c2 -> getBoolOp bo <$> convCond c1 <*> convCond c2+ Child @_ @ref tabParam cond ->+ getRef @(RdFrom (TRelDef sch ref)) True (demote @(TRelDef sch ref)).rdCols+ tabParam cond+ Parent @_ @ref cond ->+ getRef @(RdTo (TRelDef sch ref)) False (demote @(TRelDef sch ref)).rdCols+ defTabParam cond+ UnsafeCond m -> m+ where+ getNot c+ | c == mempty = mempty+ | otherwise = "not (" <> c <> ")"+ getBoolOp bo cc1 cc2+ | cc1 == mempty = cc2 -- so EmptyCond works both with &&& and |||+ | cc2 == mempty = cc1+ | otherwise = case bo of+ And -> cc1 <> " and " <> cc2+ Or -> "(" <> cc1 <> " or " <> cc2 <> ")"+ getRef+ :: forall tab. CTabDef sch tab+ => Bool -> [(Text, Text)] -> TabParam sch tab -> Cond sch tab+ -> CondMonad Text+ getRef isChild cols tabParam cond = do+ tpp <- tabPref+ modify (+1)+ cnum <- get+ (tpc, condInt, TextI ordInt, condExt) <- local (second (cnum <|))+ $ (,,,) <$> tabPref <*> convCond tabParam.cond+ <*> convOrd tabParam.order <*> convCond cond+ pure $ mkExists tpp tpc condInt ordInt condExt+ where+ mkExists tpp tpc cin oint cout+ = "exists (select 1 from (select * from " <> tn <> " " <> tpc+ <> " where "+ <> T.intercalate " and " (+ (\(ch,pr) -> tpc <> "." <> ch <> " = "+ <> tpp <> "." <> pr)+ . (if isChild then id else swap)+ <$> cols)+ <> (if T.null cin then "" else " and " <> cin)+ <> case tabParam of+ TabParam EmptyCond [] (LO Nothing Nothing) -> ""+ TabParam _ _ (convLO -> loTxt) ->+ (if T.null oint then "" else " order by " <> oint) <> loTxt+ <> ") " <> tpc+ <> (if T.null cout then "" else " where " <> cout)+ <> ")"+ where+ tn = qualName $ demote @tab++pgCond :: forall sch t . Int -> Cond sch t -> (Text, [SomeToField])+pgCond n cond = evalRWS (convCond cond) ("q", pure n) 0++pgOrd :: forall sch t. Int -> [OrdFld sch t] -> (TextI ",", [SomeToField])+pgOrd n ord = evalRWS (convOrd ord) ("o", pure n) 0++pgDist :: forall sch t. Int -> Dist sch t -> (DistTexts, [SomeToField])+pgDist n dist = evalRWS (convDist dist) ("o", pure n) 0++withCondWithPath :: forall sch t r. (forall t'. Cond sch t' -> r) ->+ [Text] -> CondWithPath sch t -> Maybe r+withCondWithPath f p (CondWithPath @p' cond) = f cond <$ guard (p == demote @p')++withCondsWithPath :: forall sch t r. (forall t'. Cond sch t' -> r) ->+ [Text] -> [CondWithPath sch t] -> Maybe r+withCondsWithPath f p = join . L.find isJust . L.map (withCondWithPath f p)++cwp :: forall path -> forall sch t t1.+ (t1 ~ TabOnPath sch t path, ToStar path) => Cond sch t1 -> CondWithPath sch t+cwp p = CondWithPath @p++rootCond :: Cond sch t -> CondWithPath sch t+rootCond = cwp []++condByPath :: Int -> [Text] -> [CondWithPath sch t] -> (Text, [SomeToField])+condByPath num p = F.fold . withCondsWithPath (pgCond num) p++ordByPath :: Int -> [Text] -> [OrdWithPath sch t] -> (TextI ",", [SomeToField])+ordByPath num p = F.fold . withOrdsWithPath (pgOrd num) p++distByPath :: Int -> [Text] -> [DistWithPath sch t] -> (DistTexts, [SomeToField])+distByPath num p = F.fold . withDistsWithPath (pgDist num) p++withOrdWithPath :: forall sch t r. (forall t'. [OrdFld sch t'] -> r) ->+ [Text] -> OrdWithPath sch t -> Maybe r+withOrdWithPath f p (OrdWithPath @p ord) = f ord <$ guard (p == demote @p)++withDistWithPath :: forall sch t r. (forall t'. Dist sch t' -> r) ->+ [Text] -> DistWithPath sch t -> Maybe r+withDistWithPath f p (DistWithPath @p dist) = f dist <$ guard (p == demote @p)++--+withOrdsWithPath :: forall sch t r . (forall t'. [OrdFld sch t'] -> r) ->+ [Text] -> [OrdWithPath sch t] -> Maybe r+withOrdsWithPath f p = join . L.find isJust . L.map (withOrdWithPath f p)++withDistsWithPath :: forall sch t r . (forall t'. Dist sch t' -> r) ->+ [Text] -> [DistWithPath sch t] -> Maybe r+withDistsWithPath f p = join . L.find isJust . L.map (withDistWithPath f p)++owp :: forall path -> forall sch t t'.+ (ToStar path, TabOnPath sch t path ~ t') =>+ [OrdFld sch t'] -> OrdWithPath sch t+owp p = OrdWithPath @p++rootOrd :: forall sch t. [OrdFld sch t] -> OrdWithPath sch t+rootOrd = owp []++dwp :: forall path -> forall sch t t'.+ (ToStar path, TabOnPath2 sch t path ~ '(t', 'RelMany)) =>+ Dist sch t' -> DistWithPath sch t+dwp p = DistWithPath @p++rootDist :: forall sch t. Dist sch t -> DistWithPath sch t+rootDist = dwp []++convPreOrd :: forall sch tab. [OrdFld sch tab] -> CondMonad [(Text, OrdDirection)]+convPreOrd = traverse processFld+ where+ processFld = \case+ OrdFld @fld od -> (, od) <$> qual @fld+ UnsafeOrd m -> m++renderOrd :: [(Text, OrdDirection)] -> TextI ","+renderOrd = foldMap (TextI . render)+ where+ render (t, show' -> od) = t <> " " <> od <> " nulls last"++convOrd :: forall sch tab. [OrdFld sch tab] -> CondMonad (TextI ",")+convOrd = fmap renderOrd . convPreOrd++data DistTexts = DistTexts+ { distinct :: Any+ , distinctOn :: TextI ","+ , orderBy :: TextI "," }+ deriving Generic+ deriving (Semigroup, Monoid) via (Generically DistTexts)++convDist :: forall sch tab. Dist sch tab -> CondMonad DistTexts+convDist = \case+ Distinct -> pure $ mempty { distinct = Any True }+ DistinctOn ofs -> convPreOrd ofs <&> \xs -> mempty+ { distinctOn = foldMap (TextI . fst) xs+ , orderBy = renderOrd xs }
+ src/PgSchema/DML/Select/Types.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE ImpredicativeTypes #-}+module PgSchema.DML.Select.Types+ -- ( QueryParam(..), qpEmpty+ -- , CondWithPath(..), OrdWithPath(..), DistWithPath(..), LimOffWithPath(..)+ -- , LO(..)+ -- , CondMonad, qRoot, qPath, qWhere, qOrderBy, qDistinct, qDistinctOn, qLimit, qOffset+ -- , Cond(..), pnull, pchild, pparent, pnot, pin, pinArr, pUnsafeCond+ -- , (|||), (&&&), (<?),(>?),(<=?),(>=?),(=?),(~=?),(~~?), showCmp, BoolOp(..)+ -- , TabParam(..), OrdFld(..), Dist(..), defTabParam, defLO, lo1+ -- , OrdDirection(..), ascf, descf, ordf+ -- , SomeToField(..)+ -- )+ where++import Control.Monad.RWS+import Data.Kind+import Data.Proxy+import Data.Singletons (demote)+import Data.List as L+import Data.List.NonEmpty as NE+import Data.String+import Data.Text(Text)+import Database.PostgreSQL.Simple.ToField+import PgSchema.Schema+import PgSchema.Types+import GHC.Generics+import GHC.Natural+import GHC.TypeLits+import PgSchema.Utils.Internal+import PgSchema.Utils.TF+++-- | Parameters that are used to describe @SELECT@.+--+-- You don't need to make it directly. Use 'MonadQP' to define 'QueryParam' instead.+--+data QueryParam sch t = QueryParam+ { qpConds :: ![CondWithPath sch t] -- ^ `where` conditions for branches of Data-Tree+ , qpOrds :: ![OrdWithPath sch t] -- ^ `order by` clauses+ , qpLOs :: ![LimOffWithPath sch t] -- ^ `limit/offset` clauses+ , qpDistinct :: ![DistWithPath sch t] -- ^ `distinct` and `distinct on` clauses+ }++-- | Empty 'QueryParam'.+--+-- It means that @SELECT@ is defined only by structure of output type+qpEmpty :: forall sch t. QueryParam sch t+qpEmpty = QueryParam [] [] [] []++type MonadQP sch t path = (TabPath sch t path, ToStar path) => RWS (Proxy path) () (QueryParam sch t) ()++-- | Execute 'MonadQP' and get 'QueryParam'.+--+-- The table `t` defines a context and becomes the "current" table+qRoot :: RWS (Proxy '[]) () (QueryParam sch t) () -> QueryParam sch t+qRoot m = fst $ execRWS m Proxy qpEmpty++-- | Change context (current table) to parent or child table.+--+-- The 'Symbol' must name the foreign-key constraint (edge to the parent or from the child)+-- for the step away from the current table.+--+qPath :: forall sch t path path'.+ forall (p :: Symbol) ->+ (TabPath sch t path', ToStar path', path' ~ path ++ '[p]) =>+ MonadQP sch t path' -> MonadQP sch t path+qPath _p m = do+ s <- get+ put $ fst $ execRWS m Proxy s++-- | Add @WHERE@ condition for the current table.+--+-- If several 'qWhere' exist they are composed according to the 'Monoid' instance for 'Cond', i.e. with '(&&&)'+qWhere :: forall sch t path. Cond sch (TabOnPath sch t path) -> MonadQP sch t path+qWhere c = modify \qp -> qp { qpConds = CondWithPath @path c : qp.qpConds }++-- | Add @ORDER BY@ condition for the current table+--+-- Several 'qOrderBy' are possible and they are composed together.+--+-- Ordering can span the current table and joined parents. For example:+--+-- @+-- qOrderBy [ascf "f1"]+-- qPath "ref-to-parent" do+-- qOrderBy [descf "f2"]+-- qOrderBy [ascf "f3"]+-- @+--+-- we get @ORDER BY t1.f1, t2.f2 DESC, t1.f3@+--+qOrderBy :: forall sch t path. [OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path+qOrderBy ofs = modify \qp -> qp { qpOrds = OrdWithPath @path ofs : qp.qpOrds }++-- | Add `DISTINCT` condition for the current table.+-- It is applied only to "root" or "children" tables.+qDistinct :: forall sch t path t'. TabOnPath2 sch t path ~ '(t', 'RelMany) =>+ MonadQP sch t path+qDistinct = modify \qp -> qp { qpDistinct = DistWithPath @path Distinct : qp.qpDistinct }++-- | Add @DISTINCT ON@ condition for the current table.+--+-- It can also be applied on a parent table because that parent is joined to the current table.+--+-- 'qDistinctOn' automatically adds fields to the @ORDER BY@ clause (as PostgreSQL requires).+-- (That's why 'OrdDirection' is needed)+-- So having+--+-- @+-- qOrderBy [descf "f0"]+-- qDistinctOn [ascf "f1"]+-- qPath "ref-to-parent" do+-- qDistinctOn [descf "f2"]+-- qDistinctOn [ascf "f3"]+-- @+--+-- we get @DISTINCT ON (t1.f1, t2.f2, t1.f3) ... ORDER BY t1.f1, t2.f2 DESC, t1.f3, t1.f0 DESC@+--+qDistinctOn :: forall sch t path. [OrdFld sch (TabOnPath sch t path)] -> MonadQP sch t path+qDistinctOn ofs = modify \qp -> qp { qpDistinct = DistWithPath @path (DistinctOn ofs) : qp.qpDistinct }++-- | Add `LIMIT` condition for the current table.+-- It is applied only to "root" or "children" tables.+--+-- If 'qLimit' is applied several times on the same path, only the last one is used+qLimit :: forall sch t path. Snd (TabOnPath2 sch t path) ~ RelMany+ => Natural -> MonadQP sch t path+qLimit n = modify \qp -> qp { qpLOs = mk qp.qpLOs }+ where+ mk xs = case L.break eq xs of+ (xs1, []) -> new : xs1+ (xs1, x:xs2) -> xs1 <> [upd x] <> xs2+ eq (LimOffWithPath @p _) = demote @p == demote @path+ upd (LimOffWithPath @p lo) = LimOffWithPath @p lo{ limit = Just n }+ new = LimOffWithPath @path LO { limit = Just n, offset = Nothing }++-- | Add `OFFSET` condition for the current table.+-- It is applied only to "root" or "children" tables.+--+-- If 'qOffset' is applied several times on the same path, only the last one is used+qOffset :: forall sch t path. Snd (TabOnPath2 sch t path) ~ RelMany+ => Natural -> MonadQP sch t path+qOffset n = modify \qp -> qp { qpLOs = mk qp.qpLOs }+ where+ mk xs = case L.break eq xs of+ (xs1, []) -> new : xs1+ (xs1, x:xs2) -> xs1 <> [upd x] <> xs2+ eq (LimOffWithPath @p _) = demote @p == demote @path+ upd (LimOffWithPath @p lo) = LimOffWithPath @p lo{offset = Just n}+ new = LimOffWithPath @path LO { offset = Just n, limit = Nothing }++-- | GADT to safely set `where` condition+data CondWithPath sch t where+ CondWithPath :: forall (path :: [Symbol]) sch t. ToStar path+ => Cond sch (TabOnPath sch t path) -> CondWithPath sch t++-- | GADT to safely set `order by` clauses+data OrdWithPath sch t where+ OrdWithPath :: forall (path :: [Symbol]) sch t. ToStar path+ => [OrdFld sch (TabOnPath sch t path)] -> OrdWithPath sch t++-- | GADT to safely set `distinct/distinct on` clauses+data DistWithPath sch t where+ DistWithPath :: forall (path :: [Symbol]) sch t. ToStar path+ => Dist sch (TabOnPath sch t path) -> DistWithPath sch t++-- | GADT to safely set `limit/offset` clauses+data LimOffWithPath sch t where+ LimOffWithPath :: forall (path :: [Symbol]) sch t.+ (TabPath sch t path, ToStar path, Snd (TabOnPath2 sch t path) ~ 'RelMany)+ => LO -> LimOffWithPath sch t++-- | Comparison constructors; each is paired with its corresponding operator+-- (e.g. '(:=)' with '(=?)').+data Cmp = (:=) | (:<=) | (:>=) | (:>) | (:<) | Like | ILike+ deriving (Show, Eq, Generic)++-- | Just boolean operations+data BoolOp = And | Or deriving (Show, Eq, Generic)++showCmp :: IsString s => Cmp -> s+showCmp = \case+ (:=) -> "="+ (:<=) -> "<="+ (:>=) -> ">="+ (:<) -> "<"+ (:>) -> ">"+ Like -> "like"+ ILike -> "ilike"++{- | RWS-Monad to generate condition.+* Read: Stack of numbers of parent tables. The top is "current table"+* Write: List of placeholder-values.++ Note: SQL is generated top-down so placeholder values appear in the correct order.++* State: Last number of table "in use"+-}+type CondMonad = RWS (Text, NonEmpty Int) [SomeToField] Int++data SomeToField where+ SomeToField :: (ToField a, Show a) => a -> SomeToField++deriving instance Show SomeToField++instance ToField SomeToField where+ toField (SomeToField v) = toField v++type CDBField sch tab fld fd = (CDBFieldInfo sch tab fld+ , TDBFieldInfo sch tab fld ~ 'RFPlain fd )++type CDBValue sch tab fld fd v =+ (CDBField sch tab fld fd, ToField v, Show v, CanConvert sch tab fld fd v)++type CDBFieldNullable sch tab fld fd =+ ( CDBField sch tab fld fd, FdNullable fd ~ 'True)++-- | GADT to safely set `where` condition for table `tab` based on definition of schema `sch`+--+-- 'Cond' is 'Monoid' with conjunction ('(&&&)') as 'mappend'+--+data Cond (sch::Type) (tab::NameNSK) where+ EmptyCond :: Cond sch tab+ -- ^ Empty Condition. Neutral for conjunction '(&&&)' and disjunction '(|||)'.+ Cmp :: forall fld v sch tab fd. CDBValue sch tab fld fd v => Cmp -> v -> Cond sch tab+ -- ^ Comparing field value with parameter+ In :: forall fld v sch tab fd. CDBValue sch tab fld fd v => NonEmpty v -> Cond sch tab+ -- ^ Check that field value belongs to non-empty list of values+ InArr :: forall fld v sch tab fd. CDBValue sch tab fld fd v => [v] -> Cond sch tab+ -- ^ Check that field value belongs to the list of values.+ -- If the list is empty, the condition evaluates to @false@.+ Null :: forall fld sch tab fd. CDBFieldNullable sch tab fld fd => Cond sch tab+ -- ^ Check that field value is @NULL@+ Not :: Cond sch tab -> Cond sch tab+ -- ^ Boolean @NOT@+ BoolOp :: BoolOp -> Cond sch tab -> Cond sch tab -> Cond sch tab+ -- ^ Conjunction and disjunction+ Child :: forall sch ref. CRelDef sch ref =>+ TabParam sch (RdFrom (TRelDef sch ref)) -> Cond sch (RdFrom (TRelDef sch ref))+ -> Cond sch (RdTo (TRelDef sch ref))+ -- ^ condition @EXISTS@ in child table. 'TabParam' is used to limit+ -- child dataset (usually with @ORDER BY@ and @LIMIT@) before applying+ -- condition on child table+ Parent :: forall sch ref . CRelDef sch ref =>+ Cond sch (RdTo (TRelDef sch ref)) -> Cond sch (RdFrom (TRelDef sch ref))+ -- ^ @JOIN@ to parent rows that satisfy the nested condition+ UnsafeCond :: CondMonad Text -> Cond sch tab+ -- ^ Unsafe condition built manually inside 'CondMonad'++-- Conjunction '(&&&)' is much more often operation for query conditions so+-- we use it for 'Semigroup'.+-- But note that 'EmptyCond' is also neutral for disjunction '(|||)'.+instance Semigroup (Cond sch tab) where+ c1 <> c2 = c1 &&& c2+ -- ^ Using conjunction ('(&&&)') for 'Semigroup' instance++instance Monoid (Cond sch tab) where+ mempty = EmptyCond++-- | Parameters for child table.+--+-- It is used to limit child dataset (usually with @ORDER BY@ and @LIMIT@) before applying+-- condition on child table+--+data TabParam sch tab = TabParam+ { cond :: Cond sch tab+ , order :: [OrdFld sch tab]+ , lo :: LO }++-- | Default empty 'TabParam'.+defTabParam :: TabParam sch tab+defTabParam = TabParam mempty mempty defLO++-- | Check that field value is @NULL@+{-# INLINE pnull #-}+pnull :: forall sch tab fd. forall name -> CDBFieldNullable sch tab name fd => Cond sch tab+pnull name = Null @name++-- | True when related rows exist in the child table and satisfy the nested condition there+--+-- 'TabParam' is used to limit child dataset (usually with @ORDER BY@ and @LIMIT@) before applying+-- condition on child table+--+{-# INLINE pchild #-}+pchild :: forall sch . forall ref -> CRelDef sch ref =>+ TabParam sch (RdFrom (TRelDef sch ref)) -> Cond sch (RdFrom (TRelDef sch ref))+ -> Cond sch (RdTo (TRelDef sch ref))+pchild name = Child @sch @name++-- | Check that condition is satisfied in parent table+{-# INLINE pparent #-}+pparent :: forall sch. forall ref -> CRelDef sch ref =>+ Cond sch (RdTo (TRelDef sch ref)) -> Cond sch (RdFrom (TRelDef sch ref))+pparent name = Parent @sch @name++-- | Boolean @NOT@+{-# INLINE pnot #-}+pnot :: Cond sch tab -> Cond sch tab+pnot = Not++{-# INLINE pUnsafeCond #-}+pUnsafeCond :: CondMonad Text -> Cond sch tab+pUnsafeCond = UnsafeCond++-- | Check that field value belongs to non-empty list of values+{-# INLINE pin #-}+pin :: forall name -> forall sch tab fd v. CDBValue sch tab name fd v+ => NonEmpty v -> Cond sch tab+pin name = In @name++-- | Check that field value belongs to the list of values.+-- If the list is empty, the condition evaluates to @false@.+{-# INLINE pinArr #-}+pinArr :: forall name -> forall sch tab fd v. CDBValue sch tab name fd v+ => [v] -> Cond sch tab+pinArr name = InArr @name++-- | Conjunction+(&&&) :: Cond sch tab -> Cond sch tab -> Cond sch tab+-- | Disjunction+(|||) :: Cond sch tab -> Cond sch tab -> Cond sch tab+EmptyCond &&& cond = cond+cond &&& EmptyCond = cond+c1 &&& c2 = BoolOp And c1 c2+EmptyCond ||| cond = cond+cond ||| EmptyCond = cond+c1 ||| c2 = BoolOp Or c1 c2+infixl 2 |||+infixl 3 &&&+--+{-# INLINE (<?) #-}+{-# INLINE (>?) #-}+{-# INLINE (<=?) #-}+{-# INLINE (>=?) #-}+{-# INLINE (=?) #-}+{-# INLINE (~=?) #-}+{-# INLINE (~~?) #-}+(<?),(>?),(<=?),(>=?),(=?)+ :: forall fld -> forall sch tab fd v. CDBValue sch tab fld fd v => v -> Cond sch tab+x <? b = Cmp @x (:<) b+x >? b = Cmp @x (:>) b+x <=? b = Cmp @x (:<=) b+x >=? b = Cmp @x (:>=) b+x =? b = Cmp @x (:=) b+(~=?),(~~?)+ :: forall fld -> forall sch tab fd v. CDBValue sch tab fld fd v => v -> Cond sch tab+x ~=? b = Cmp @x Like b+x ~~? b = Cmp @x ILike b+infix 4 <?, >?, <=?, >=?, =?, ~=?, ~~?++data OrdDirection = Asc | Desc deriving Show++data OrdFld sch tab where+ OrdFld :: forall fld sch tab fd. CDBField sch tab fld fd =>+ OrdDirection -> OrdFld sch tab+ UnsafeOrd :: CondMonad (Text, OrdDirection) -> OrdFld sch tab++data Dist sch tab where+ Distinct :: Dist sch tab+ -- | Having 'DistinctOn' we automatically add fields from 'DistinctOn'+ -- into the begining of @ORDER BY@.+ -- (It is "good enough" and more simple than check it on type level).+ --+ -- That's why we use 'OrdFld' who include 'OrdDirection'.+ -- Naturally 'OrdDirection' is not used in DISTINCT ON part itself.+ --+ -- Beside that @DISTINCT ON@ part can include expressions like @ORDER BY@.+ -- We can also use 'UnsafeOrd' here+ DistinctOn :: [OrdFld sch tab] -> Dist sch tab++{-# INLINE ordf #-}+ordf+ :: forall fld -> forall sch tab fd. CDBField sch tab fld fd+ => OrdDirection -> OrdFld sch tab+ordf fld = OrdFld @fld++{-# INLINE ascf #-}+ascf :: forall fld -> forall sch tab fd. CDBField sch tab fld fd => OrdFld sch tab+ascf fld = ordf fld Asc++{-# INLINE descf #-}+descf :: forall fld -> forall sch tab fd. CDBField sch tab fld fd => OrdFld sch tab+descf fld = ordf fld Desc++data LO = LO+ { limit :: Maybe Natural+ , offset :: Maybe Natural }+ deriving Show++defLO :: LO+defLO = LO Nothing Nothing++lo1 :: LO+lo1 = LO (Just 1) Nothing
+ src/PgSchema/DML/Update.hs view
@@ -0,0 +1,61 @@+module PgSchema.DML.Update where++import Data.String+import Data.Text as T+import Database.PostgreSQL.Simple+import GHC.Int+import PgSchema.Ann+import PgSchema.DML.Select+import PgSchema.DML.Select.Types+import PgSchema.DML.Insert.Types+import PgSchema.Schema+import PgSchema.Types+import PgSchema.Utils.Internal+import Prelude as P++-- TODO:+-- updateByKey Connection -> [r] -> IO [r']+-- updateByKeyJSON Connection -> [r] -> IO [r']+-- updateExp (e.q. update t set a = a + c + 1 where b > 10)++-- | Update rows matching a condition; the result type selects which columns are returned.+updateByCond :: forall ann -> forall r r'.+ (ann ~ 'Ann ren sch d t, UpdateReturning ann r r') =>+ Connection -> r -> Cond sch t -> IO [r']+updateByCond ann @r @r' conn r (updateText ann @r @r' -> (q,ps)) =+ trace' (q <> "\n\n" <> P.show ps <> "\n\n")+ $ fmap (fmap (unPgTag @ann @r'))+ $ query conn (fromString q)+ $ PgTag @ann @r r :. ps++-- | Update records by condition without @RETURNING@.+updateByCond_ :: forall ann -> forall r.+ (ann ~ 'Ann ren sch d t, UpdateNonReturning ann r) =>+ Connection -> r -> Cond sch t -> IO Int64+updateByCond_ ann @r conn r (updateText_ ann @r -> (q, ps)) =+ trace' (q <> "\n\n" <> P.show ps <> "\n\n")+ $ execute conn (fromString q)+ $ PgTag @ann @r r :. ps++-- | Construct SQL text for updating records by condition and returning some fields.+updateText :: forall ann -> forall r r' s.+ (CRecInfo ann r, CRecInfo ann r', IsString s, Monoid s, ann ~ 'Ann ren sch d t)+ => Cond sch t -> (s, [SomeToField])+updateText ann @r @r' (updateText_ ann @r -> (q, p)) = (q <> " returning " <> fs', p)+ where+ ri' = getRecordInfo @ann @r'+ fs' = fromText $ T.intercalate "," [fi.fieldDbName | fi <- ri'.fields]++-- | Construct SQL text for updating records by condition without @RETURNING@.+updateText_+ :: forall ann -> forall r s. (IsString s, Monoid s, CRecInfo ann r)+ => Cond sch t -> (s, [SomeToField])+updateText_ ann @r (pgCond 0 -> (condTxt, condParams)) =+ ("update " <> tn <> " t0 set " <> fs <> fromText whereTxt, condParams )+ where+ ri = getRecordInfo @ann @r+ fs = intercalate' ", " [fromText fi.fieldDbName <> " = ?" | fi <- ri.fields]+ tn = fromText $ qualName ri.tabName+ whereTxt+ | T.null condTxt = mempty+ | otherwise = " where " <> condTxt
+ src/PgSchema/GenDot.hs view
@@ -0,0 +1,78 @@+{-| Helper module: export a schema as DOT (Graphviz-style graphs). Useful for+debugging and documenting a schema; not the primary API for database work through+@pg-schema@.++It is exposed as a small utility; it could be made non-public in a future release.+Avoid depending on it in compatibility-sensitive code unless you really need graph output.+-}+module PgSchema.GenDot where++import Data.Foldable as F+import Data.List as L+import Data.Map as M+import Data.Singletons+import Data.Text as T++import PgSchema.Schema+++data DotOper+ = ExcludeToTab NameNS Text+ -- ^ Exclude relation to given table from DOT representation.++genDot :: forall sch. CSchema sch+ => Bool -- ^ Whether to use qualified names+ -> [DotOper] -- ^ Operations to exclude relations from DOT representation+ -> Text+genDot isQual dos = F.fold+ [ "digraph G {\n"+ , " penwidth=2\n\n"+ , F.fold dbSchemas+ , ""+ , T.unlines relTxts+ , "}\n"+ ]+ where+ tabs = demote @(TTabs sch)+ tim = tabInfoMap @sch+ rels = L.concatMap elems . elems $ tiFrom <$> tim+ tabsByName = M.fromListWith (<>)+ $ ((,) <$> nnsName <*> pure . nnsNamespace) <$> tabs+ qName nns+ | isQual = q+ | otherwise = case M.lookup (nnsName nns) tabsByName of+ Just [_] -> (nnsName nns,False)+ _ -> q+ where+ q = (qualName nns,True)+ qNameQuo nns = case qName nns of+ (x,False) -> x+ (x,True) -> "\"" <> x <> "\""+ qName' nns = case exTo of+ [] -> nns'+ _ -> nns' <> " [label=\"" <> fst (qName nns) <> ": "+ <> T.unwords exTo <> "\"]"+ where+ nns' = qNameQuo nns+ exTo = [t | ExcludeToTab x t <- dos, RelDef {..} <- rels+ , rdTo == x, rdFrom == nns]+ dbSchemas = dbSchema <$> nub (nnsNamespace <$> tabs)+ dbSchema schName = F.fold+ [ " subgraph cluster_" <> schName <> "{\n"+ , " label=\"" <> schName <> "\"\n"+ , T.unlines+ $ (" " <>) . qName' <$> L.filter ((==schName) . nnsNamespace) tabs+ , " }\n"+ ]+ relTxts = rel <$> L.filter notExcluded rels+ where+ notExcluded RelDef{..} = L.null [()|ExcludeToTab x _ <- dos, rdTo ==x]+ rel RelDef {..} = " " <> qNameQuo rdFrom <> "->" <> qNameQuo rdTo <> clr+ where+ clr = case mbTabFlds >>= isNullableRef of+ Just True -> "[color=\"green\"]"+ _ -> ""+ where+ mbTabFlds = tiFlds <$> M.lookup rdFrom tim+ isNullableRef tabFlds = L.any fdNullable+ <$> traverse ((`M.lookup` tabFlds) . fst) rdCols
+ src/PgSchema/Generation.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: PgSchema.Generation+-- Copyright: (c) Dmitry Olshansky+-- License: BSD-3-Clause+-- Maintainer: olshanskydr@gmail.com, dima@typeable.io+-- Stability: experimental+--+-- === Generation of type-level database schema definitions+--+-- Typically you build an executable that imports this module+-- and run it to emit the schema definition.+--+module PgSchema.Generation+ (updateSchemaFile, GenNames(..), AddRelation(..)+ , NameNS'(..), NameNS, (->>)+ ) where++import Control.Monad+import Control.Monad.Catch+import Data.Bifunctor+import Data.ByteString as BS hiding (readFile, writeFile)+import Data.Coerce+import Data.Functor+import Data.List qualified as L+import Data.List.NonEmpty as NE+import Data.Map as M+import Data.Maybe as Mb+import Data.Set as S+import Data.String+import Data.Text as T+import Data.Text.IO as T+import Data.Traversable+import Database.PostgreSQL.Simple+import GHC.Int+import GHC.Records+import GHC.TypeLits ( Symbol )+import PgSchema.Ann+import PgSchema.DML.Select+import PgSchema.DML.Select.Types+import PgSchema.Schema+import PgSchema.Schema.Catalog+import PgSchema.Schema.Info+import PgSchema.Types+import PgSchema.Utils.ShowType+import Prelude as P+import System.Directory+import System.Environment+++data ExceptionSch+ = ConnectException ByteString SomeException+ | GetDataException (Text, [SomeToField]) SomeException+ deriving Show++instance Exception ExceptionSch++data AddRelation = AddRelation+ { name :: Text+ -- ^ name of an additional (non-existing in the database) relation.+ -- All additional relations will be added with the namespace "_add".+ , from :: NameNS+ , to :: NameNS+ , cols :: [(Text, Text)] }++data GenNames = GenNames+ { schemas :: [Text] -- ^ generate data for all tables in these schemas+ , tables :: [NameNS] -- ^ generate data for these tables+ , addRelations :: [AddRelation] -- ^ additional relations. Be careful!+ }++type AnnCat tn = 'Ann RenamerId PgCatalog 3 (PGC tn)++selCat :: forall (tn :: Symbol) -> forall r. (Selectable (AnnCat tn) r)+ => Connection -> QueryParam PgCatalog (PGC tn) -> IO ([r], (Text,[SomeToField]))+selCat tn = selectSch (AnnCat tn)++selTxt :: forall (tn :: Symbol) -> forall r. (Selectable (AnnCat tn) r)+ => QueryParam PgCatalog (PGC tn) -> (Text,[SomeToField])+selTxt tn @r = selectText (AnnCat tn) @r++getSchema+ :: Connection -- ^ connection to PostgreSQL database+ -> GenNames -- ^ names of schemas and tables to generate from the database+ -> IO ([PgType], [PgClass], [PgRelation])+getSchema conn GenNames {..} = do+ types <- selCat "pg_type" conn qpTyp `catch`+ (throwM . GetDataException (selTxt "pg_type" @PgType qpTyp))+ classes <- L.filter checkClass . fst <$> selCat "pg_class" conn qpClass `catch`+ (throwM . GetDataException (selTxt "pg_class" @PgClass qpClass))+ relations <- L.filter checkRels . (Mb.mapMaybe (mkRel classes) addRelations <>)+ . fst <$> selCat "pg_constraint" conn qpRel `catch`+ (throwM . GetDataException (selTxt "pg_constraint" @PgRelation qpRel))+ pure (fst types, classes, relations)+ where+ mkRel classes ar = do+ conkey <- mkNums ar.from $ fst <$> ar.cols+ confkey <- mkNums ar.to $ snd <$> ar.cols+ pure PgRelation+ { constraint__namespace = "nspname" =: "_add"+ , conname = ar.name+ , constraint__class = toPgClassShort ar.from+ , constraint__fclass = toPgClassShort ar.to+ , .. }+ where+ toPgClassShort nns = PgClassShort+ { class__namespace = "nspname" =: nns.nnsNamespace+ , relname = nns.nnsName }+ mkNums nns fields = do+ pgcl <- L.find (\c -> c.class__namespace == "nspname" =: nns.nnsNamespace+ && c.relname == nns.nnsName) classes+ inds <- for fields \fld ->+ L.findIndex ((==fld) . (.attname)) pgcl.attribute__class+ pure $ pgArr' $ fromIntegral . (+1) <$> inds++-- all data are ordered to provide stable `hashSchema`+ qpTyp = qRoot @PgCatalog @(PGC "pg_type") do+ qOrderBy [ascf "typname", ordNS "typnamespace"]+ qPath "enum__type" do+ qOrderBy [ascf "enumsortorder"]+ qpClass = qRoot @PgCatalog @(PGC "pg_class") do+ qWhere $ condClass &&& pin "relkind" (PgChar <$> 'v' :| "r") -- views & tables+ qOrderBy [ascf "relname", ordNS "relnamespace"]+ qPath "attribute__class" do+ qWhere $ "attnum" >? (0::Int16)+ qOrderBy [ascf "attnum"]+ qPath "constraint__class" do+ qOrderBy [ascf "conname"]+ qpRel = qRoot @PgCatalog @(PGC "pg_constraint") do+ qWhere+ $ pparent (PGC "constraint__class") condClass+ ||| pparent (PGC "constraint__fclass") condClass+ qOrderBy [ascf "conname", ordNS "connamespace"]+ ordNS fld = UnsafeOrd do+ o <- tabPref+ pure ("(select nspname from pg_catalog.pg_namespace p where p.oid = "+ <> o <> "." <> fld <> ")", Asc)+ condClass = condSchemas ||| condTabs+ where+ condSchemas = pparent (PGC "class__namespace")+ $ foldMap (pin "nspname") $ nonEmpty schemas+ condTabs+ = pparent (PGC "class__namespace")+ (foldMap (pin "nspname" . fmap nnsNamespace) (nonEmpty tables))+ &&& foldMap (pin "relname" . fmap nnsName) (nonEmpty tables)+ checkClass PgClass {..}+ = (coerce class__namespace `L.elem` schemas)+ || (coerce class__namespace ->> relname `L.elem` tables)+ checkRels PgRelation {..} =+ check constraint__class || check constraint__fclass+ where+ check PgClassShort {..}+ = (coerce class__namespace `L.elem` schemas)+ || (coerce class__namespace ->> relname `L.elem` tables)++getDefs+ :: ([PgType], [PgClass], [PgRelation])+ -> (Map NameNS TypDef+ , Map (NameNS,Text) FldDef+ , Map NameNS (TabDef, [NameNS], [NameNS])+ , Map NameNS RelDef)+getDefs (types,classes,relations) =+ ( M.fromList $ ptypDef <$> ntypes+ , M.fromList $ pfldDef <$> attrs+ , M.fromList $ ptabDef <$> classes+ , M.fromList relDefs )+ where+ classAttrs = ((,) <$> tabKey <*> attribute__class) <$> classes+ mClassAttrs =+ M.fromList [((c, attnum a), attname a)| (c,as) <- classAttrs, a <- as]+ attrs :: [(NameNS, PgAttribute)] =+ L.concatMap (\(a,xs) -> (a,) <$> xs) classAttrs+ typKey = NameNS <$> (coerce . type__namespace) <*> typname+ ntypes = ntype <$> L.filter ((`S.member` attrsTypes) . typKey) types+ where+ ntype t = (t, typKey <$> M.lookup (fromPgOid $ typelem t) mtypes)+ attrsTypes = S.fromList $ (typKey . attribute__type . snd <$> attrs)+ <> [pgc "int8", pgc "float8"] -- added for Aggr+ mtypes = M.fromList $ (\x -> (fromPgOid $ oid x , x)) <$> types+ ptypDef (x@PgType{..}, typElem) = (typKey x, TypDef {..})+ where+ typCategory = T.singleton $ coerce typcategory+ typEnum = enumlabel <$> coerce enum__type+ pfldDef (cname::NameNS, PgAttribute{..}) = ((cname,attname), FldDef{..})+ where+ fdType = typKey attribute__type+ fdNullable = not attnotnull+ fdHasDefault = atthasdef+ tabKey+ :: forall r .+ ( HasField "class__namespace" r ("nspname" := Text)+ , HasField "relname" r Text )+ => r -> NameNS+ tabKey r = NameNS (coerce r.class__namespace) r.relname+ ptabDef c@PgClass{..} = (tabName, (TabDef{..}, froms, tos))+ where+ tabName = tabKey c+ tdFlds = attname <$> coerce attribute__class+ tdKey = L.concat $ keysBy (=='p')+ tdUniq = keysBy (=='u')+ keysBy f+ = Mb.mapMaybe -- if something is wrong exclude such constraint+ (traverse numToName . unPgArr' . (.conkey))+ $ L.filter (f . coerce . contype) (coerce constraint__class)+ where+ numToName a =+ attname <$> L.find ((==a) . attnum) attribute__class+ (froms, tos) = bimap getNames getNames (rdFrom, rdTo)+ where+ getNames f = fst <$> L.filter ((==tabName) . f . snd) relDefs+ relDefs = Mb.mapMaybe mbRelDef relations+ mbRelDef PgRelation {..} = sequenceA+ ( rdName+ , zipWithM getName2 (unPgArr' conkey) (unPgArr' confkey)+ <&> \rdCols -> RelDef{..})+ where+ rdName = NameNS (coerce constraint__namespace) conname+ rdFrom = tabKey constraint__class+ rdTo = tabKey constraint__fclass+ getName t n = M.lookup (t,n) mClassAttrs+ getName2 n1 n2 = (,) <$> getName rdFrom n1 <*> getName rdTo n2++-- | Update (or create) the Haskell file containing the schema definition+updateSchemaFile+ :: Bool -- ^ verbose mode+ -> String -- ^ file name+ -> Either String ByteString+ -- ^ name of environment variable with connection string, or+ -- the connection string itself.+ -- When this environment variable is not set or the connection string is empty,+ -- we do nothing.+ -> Text -- ^ haskell module name to generate+ -> Text -- ^ name of generated haskell type for schema+ -> GenNames -- ^ names of schemas in database or tables to generate+ -> IO Bool+updateSchemaFile verbose fileName ecs moduleName schName genNames = do+ connStr <- either getConnStr pure ecs+ if BS.null connStr+ then pure False+ else do+ fe <- doesFileExist fileName+ conn <- connectPostgreSQL connStr+ P.putStrLn "Trying to get schema"+ schema <- getSchema conn genNames+ P.putStrLn "Generation"+ let newTxt = moduleText schema+ needGen <- if fe+ then (/= newTxt) <$> T.readFile fileName+ else pure True+ P.putStrLn $ "Need to generate file: " <> P.show needGen+ when needGen do+ when fe $ copyFile fileName (fileName <> ".bak")+ T.writeFile fileName newTxt+ when verbose $ print schema+ pure needGen+ where+ getConnStr env =+ handle (const @_ @SomeException $ pure "") (fromString <$> getEnv env)+ moduleText = genModuleText moduleName schName . getDefs++mkInst :: ShowType a => Text -> [Text] -> a -> Text+mkInst name pars a+ = "instance C" <> sgn <> " where\n"+ <> " type T" <> sgn <> " = \n"+ <> " " <> showSplit 6 70 a <> "\n"+ where+ sgn = T.intercalate " " (name : pars)++textTypDef :: Text -> NameNS -> TypDef -> Text+textTypDef sch typ td@TypDef {..} = mkInst "TypDef" ss td <> pgEnum+ where+ ss = [sch, showType typ]+ st = T.intercalate " " ss+ pgEnum+ | L.null typEnum = ""+ | otherwise+ = "data instance PGEnum " <> st <> "\n = "+ <> showSplit' "|" 2 70+ ( T.intercalate " | "+ $ ((T.toTitle (nnsName typ) <> "_") <>) <$> typEnum )+ <> " deriving (Show, Read, Ord, Eq, Generic, Bounded, Enum)\n\n"+#ifdef MK_HASHABLE+ <> "instance Hashable (PGEnum " <> st <> ")\n\n"+#endif+ <> "instance NFData (PGEnum " <> st <> ")\n\n"++textTabDef :: Text -> NameNS -> TabDef -> Text+textTabDef sch tab = mkInst "TabDef" [sch, showType tab]++textRelDef :: Text -> NameNS -> RelDef -> Text+textRelDef sch relName rel =+ "instance CRelDef " <> sch <> " " <> showType relName <> " where\n" <>+ " type TRelDef " <> sch <> " " <> showType relName <> " = " <> showType rel <> "\n\n"++textTabRel :: Text -> NameNS -> [NameNS] -> [NameNS] -> Text+textTabRel sch tab froms tos+ = "instance CTabRels " <> pars <> " where\n"+ <> " type TFrom " <> pars <> " = \n"+ <> " " <> showSplit 6 70 froms <> "\n"+ <> " type TTo " <> pars <> " = \n"+ <> " " <> showSplit 6 70 tos <> "\n"+ where+ pars = T.intercalate " " [sch, showType tab]++-- Generate Ref in type-level format (using 'FldDef directly)+textRef :: FldDef -> FldDef -> Text -> Text -> Text+textRef fromDef toDef fromName toName =+ "'Ref " <> showType fromName <> " (" <> showType fromDef <> ") "+ <> showType toName <> " (" <> showType toDef <> ")"++-- RHS only (for closed type family equations)+rhsPlain :: FldDef -> Text+rhsPlain fd = "'RFPlain (" <> showType fd <> ")"++rhsToHere :: NameNS -> NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text+rhsToHere tab fromTab rel mfld =+ let refsText = T.intercalate "\n , " $+ [ textRef (mfld M.! (fromTab, fromName)) (mfld M.! (tab, toName)) fromName toName+ | (fromName, toName) <- rdCols rel+ ]+ in "'RFToHere " <> showType fromTab <> "\n '[ " <> refsText <> " ]"++rhsFromHere :: NameNS -> NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text+rhsFromHere tab toTab rel mfld =+ let refsText = T.intercalate "\n , " $+ [ textRef (mfld M.! (tab, fromName)) (mfld M.! (toTab, toName)) fromName toName+ | (fromName, toName) <- rdCols rel+ ]+ in "'RFFromHere " <> showType toTab <> "\n '[ " <> refsText <> " ]"++rhsSelfRef :: NameNS -> RelDef -> M.Map (NameNS, Text) FldDef -> Text+rhsSelfRef tab rel mfld =+ let refsText = T.intercalate "\n , " $+ [ textRef (mfld M.! (tab, fromName)) (mfld M.! (tab, toName)) fromName toName+ | (fromName, toName) <- rdCols rel+ ]+ in "'RFSelfRef " <> showType tab <> "\n '[ " <> refsText <> " ]"++-- Closed type family TDBFieldInfo<Sch> and single CDBFieldInfo instance+typeFamilyName :: Text -> Text+typeFamilyName sch = "TDBFieldInfo" <> sch++typeErrorMsg+ :: Text -> Text -> [Text] -> [Text] -> Text+typeErrorMsg sch tabStr fields rels =+ "TE.TypeError (TE.Text \"In schema \" TE.:<>: TE.ShowType " <> sch+ <> "\n TE.:$$: TE.Text \"for table \" TE.:<>: TE.ShowType " <> tabStr+ <> "\n TE.:$$: TE.Text \"name \" TE.:<>: TE.ShowType f TE.:<>: TE.Text \" is not defined.\""+ <> "\n TE.:$$: TE.Text \"\""+ <> "\n TE.:$$: TE.Text \"Valid values are:\""+ <> "\n TE.:$$: TE.Text \" Fields: " <> T.intercalate ", " fields <> ".\""+ <> "\n TE.:$$: TE.Text \" Foreign key constraints: " <> T.intercalate ", " rels <> ".\""+ <> "\n TE.:$$: TE.Text \"\""+ <> "\n TE.:$$: TE.Text \"Your source or target type or renaimer is probably invalid.\""+ <> "\n TE.:$$: TE.Text \"\""+ <> ")"++textClosedFieldInfoTF+ :: Text+ -> (M.Map (NameNS, Text) FldDef+ , M.Map NameNS (TabDef, [NameNS]+ , [NameNS]), M.Map NameNS RelDef)+ -> Text+textClosedFieldInfoTF schName (mfld, mtab, mrel) =+ "type family " <> tfName+ <> " (t :: NameNSK) (f :: TL.Symbol) :: RecFieldK NameNSK where\n" <> equations <> "\n"+ <> "instance (ToStar (TDBFieldInfo " <> schName <> " t f), ToStar t, ToStar f) => CDBFieldInfo " <> schName <> " t f where\n"+ <> " type TDBFieldInfo " <> schName <> " t f = " <> tfName <> " t f\n\n"+ where+ tfName = typeFamilyName schName+ -- All (tab, fldName, rhs) in deterministic order: by table, then plain fields,+ -- then toHere, then fromHere, then selfRef (for self-FK).+ plainEntries =+ [ (tab, fldName, rhsPlain fd) | ((tab, fldName), fd) <- M.toList mfld ]+ toHereEntries =+ [ (tab, nnsName relName, rhsToHere tab (rdFrom rel) rel mfld)+ | (tab, (_, _froms, tos)) <- M.toList mtab, relName <- tos+ , let rel = mrel M.! relName+ , not (rdFrom rel == tab && rdTo rel == tab)+ ]+ fromHereEntries =+ [ (tab, nnsName relName, rhsFromHere tab (rdTo rel) rel mfld)+ | (tab, (_, froms, _tos)) <- M.toList mtab, relName <- froms+ , let rel = mrel M.! relName+ , not (rdFrom rel == tab && rdTo rel == tab)+ ]+ selfEntries =+ [ (tab, nnsName relName, rhsSelfRef tab rel mfld)+ | (tab, (_, froms, tos)) <- M.toList mtab+ , relName <- L.nub (tos <> froms)+ , let rel = mrel M.! relName+ , rdFrom rel == tab && rdTo rel == tab+ ]+ allEntries = plainEntries <> toHereEntries <> fromHereEntries <> selfEntries+ eqnLine tab fldName rhs =+ " " <> tfName <> " " <> showType tab <> " \"" <> fldName <> "\" = " <> rhs <> "\n"+ perTableDefault _ tabStr fieldNames relNames =+ " " <> tfName <> " " <> tabStr <> " f = " <> typeErrorMsg schName tabStr fieldNames relNames <> "\n"+ tableBlocks =+ [ mconcat [ eqnLine tab fld rhs | (t, fld, rhs) <- allEntries, t == tab ]+ <> perTableDefault tab (showType tab) (tdFlds td) ((nnsName <$> froms) <> (nnsName <$> tos))+ | (tab, (td, froms, tos)) <- M.toList mtab ]+ equations = mconcat tableBlocks <> " " <> tfName <> " t f = "+ <> typeErrorMsgFinal <> "\n"+ typeErrorMsgFinal =+ "TE.TypeError (TE.Text \"In schema \" TE.:<>: TE.ShowType " <> schName+ <> " TE.:<>: TE.Text \" the table \" TE.:<>: TE.ShowType t TE.:<>: TE.Text \" is not defined.\""+ <> "\n TE.:$$: TE.Text \"\""+ <> ")"+++genModuleText+ :: Text -- ^ module name+ -> Text -- ^ schema name+ -> (Map NameNS TypDef+ , Map (NameNS,Text) FldDef+ , Map NameNS (TabDef, [NameNS], [NameNS])+ , Map NameNS RelDef)+ -> Text+genModuleText moduleName schName (mtyp, mfld, mtab, mrel)+ = "{- HLINT ignore -}\n"+ <> "{-# LANGUAGE FlexibleContexts #-}\n"+ <> "{-# LANGUAGE TypeFamilies #-}\n"+ <> "{-# LANGUAGE UndecidableInstances #-}\n"+ <> "{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}\n"+ <> "{-# OPTIONS_GHC -fno-warn-unused-imports #-}\n"+ <> "{-# OPTIONS_GHC -freduction-depth=300 #-}\n"+ <> "module " <> moduleName <> " where\n\n"+ <> "-- This file is generated and can't be edited.\n\n"+ <> "import Control.DeepSeq\n" -- for PGEnum if exist+#ifdef MK_HASHABLE+ <> "import Data.Hashable\n" -- for PGEnum if exist+#endif+ <> "import GHC.Generics\n" -- for PGEnum if exists+ <> "import GHC.TypeError qualified as TE\n"+ <> "import GHC.TypeLits qualified as TL\n"+ <> "import PgSchema.Import\n"+ <> "data " <> schName <> "\n\n"+ <> mconcat (uncurry (textTypDef schName) <$> M.toList mtyp)+ <> mconcat ((\(tab,(td,_,_)) -> textTabDef schName tab td) <$> M.toList mtab)+ <> mconcat ([ textRelDef schName relName rel | (relName, rel) <- M.toList mrel ])+ <> mconcat ((\(tab,(_,froms,tos)) -> textTabRel schName tab froms tos)+ <$> M.toList mtab)+ <> textClosedFieldInfoTF schName (mfld, mtab, mrel)+ <> "instance CSchema " <> schName <> " where\n"+ <> " type TTabs " <> schName <> " = " <> showSplit 4 70 (keys mtab) <> "\n"+ <> " type TTypes " <> schName <> " = " <> showSplit 4 70 (keys mtyp) <> "\n"++showSplit :: ShowType a => Int -> Int -> a -> Text+showSplit shift width = showSplit' "," shift width . showType++showSplit' :: Text -> Int -> Int -> Text -> Text+showSplit' delim shift width+ = T.unlines . mapTail ((T.replicate shift " " <>) . (delim <>))+ . L.map (T.intercalate delim) . fst . mkLines+ where+ mapTail _ [] = []+ mapTail f (x:xs) = x : L.map f xs+ mkLines = L.foldr step ([],0). T.splitOn delim+ where+ step t (xs,len)+ | tlen + len > width = ([t] : xs, tlen)+ | otherwise = case xs of+ [] -> ([[t]], tlen)+ z : zs -> ((t:z):zs, tlen + len)+ where+ tlen = T.length t
+ src/PgSchema/Import.hs view
@@ -0,0 +1,46 @@+{-| Shared import surface for /generated/ schema modules only.++Do @not@ import this module from handwritten application or library code.++@pg-schema@ tooling emits a schema module (per database or slice) that imports+"PgSchema.Import" to pull in the type classes, type families, and promoted data+that describe your schema at compile time. That generated module is what your+application should import alongside "PgSchema.DML" (and optionally+"PgSchema.Generation" for the codegen executable).++"PgSchema.Import" is a thin re-export hub: it exists so generated files stay short+and stable across @pg-schema@ versions, and so the generator does not need to+duplicate long import lists from internal modules. It is part of the package’s+@exposed-modules@ only so those generated modules (which live in your project, not+inside this package) can depend on it via ordinary package imports.++If you import "PgSchema.Import" directly, you bypass the intended layering, gain no+extra capability, and risk silent breakage when the re-export set changes.+Treat it as an implementation detail of codegen output, not as a public API to build on.+-}+module PgSchema.Import+ (+ -- * CSchema class+ CSchema(..)+ -- * CTabDef class+ , CTabDef(..), TabDef'(..)+ -- * CDBFieldInfo class+ , CDBFieldInfo(..), FldDef'(..), RelDef'(..)+ -- * CTypDef class+ , CTypDef(..), TypDef'(..)+ -- * RecField class+ , RecField'(..), RecFieldK, Ref'(..)+ -- * TRelDef type family+ , CRelDef(..)+ -- * CTabRels class+ , CTabRels(..)+ -- * PGEnum type+ , PGEnum+ -- * NameNS type classes+ , NameNSK, type (->>)+ , ToStar+ ) where++import PgSchema.Schema+import PgSchema.Types+import PgSchema.Utils.Internal
+ src/PgSchema/Schema.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ParallelListComp #-}+module PgSchema.Schema where++import Data.Kind+import Data.List as L+import Data.Map as M+import Data.Singletons+import Data.Singletons.TH+import Data.String+import Data.Text as T hiding (show)+import Data.Type.Bool+import Data.Type.Equality+import GHC.TypeLits+import PgSchema.Utils.Instances()+import PgSchema.Utils.Internal+import PgSchema.Utils.TF+++-- | Supported SQL aggregate functions+data AggrFun = ACount | AMin | AMax | ASum | AAvg+ deriving Show++-- | Qualified PostgreSQL name: namespace (schema) + local name.+data NameNS' s = NameNS+ { nnsNamespace :: s -- ^ Namespace (database schema), e.g. @public@ or @pg_catalog@.+ , nnsName :: s -- ^ Unqualified table / relation / type name.+ } deriving (Show, Eq, Ord)++-- | Description of a PostgreSQL type (category, array element, enum labels).+data TypDef' s = TypDef+ { typCategory :: s -- ^ PostgreSql internal type category+ , typElem :: Maybe (NameNS' s) -- ^ For array types: element type name; 'Nothing' for non-arrays.+ , typEnum :: [s] -- ^ Enum label names for enum types; empty list for non-enums.+ } deriving Show++-- | Column-level type and nullability/default flags.+data FldDef' s = FldDef+ { fdType :: NameNS' s -- ^ PostgreSQL type of the column.+ , fdNullable :: Bool -- ^ 'True' if the column allows NULL.+ , fdHasDefault :: Bool -- ^ 'True' if the column has a default value; affects mandatory-field logic.+ } deriving Show++-- | Table shape: ordered column names, primary key, unique constraints.+data TabDef' s = TabDef+ { tdFlds :: [s] -- ^ Physical column names in order.+ , tdKey :: [s] -- ^ Primary key column names.+ , tdUniq :: [[s]] -- ^ Unique constraints as lists of column names.+ } deriving Show++-- | Foreign-key-style link between two qualified tables and column mapping.+data RelDef' s = RelDef+ { rdFrom :: NameNS' s -- ^ Referencing table (child).+ , rdTo :: NameNS' s -- ^ Referenced table (parent).+ , rdCols :: [(s, s)] -- ^ Pairs @(fromColumn, toColumn)@.+ } deriving Show++-- | Cardinality of a relation edge (one vs many from this table’s perspective).+data RelType = RelOne | RelMany deriving Show++-- | Field of a logical record: plain column, aggregate, or relation hop.+data RecField' s p+ = RFEmpty s -- ^ Placeholder / unnamed slot (depending on schema codegen).+ | RFPlain (FldDef' s) -- ^ Ordinary column with 'FldDef''.+ | RFAggr (FldDef' s) AggrFun Bool+ -- ^ Aggregate field: 'FldDef'', which aggregate, and whether it is allowed outside @GROUP BY@+ -- (when 'True': any select; when 'False': only with @GROUP BY@).+ | RFToHere p [Ref' s]+ -- ^ Relation: navigate @p@ toward the current table (“to here”).+ | RFFromHere p [Ref' s]+ -- ^ Relation: navigate @p@ away from the current table (“from here”).+ | RFSelfRef p [Ref' s] -- ^ Self-referential relation through path @p@.+ deriving Show++-- | One step of a join path: source column, types, target column.+data Ref' s = Ref+ { fromName :: s -- ^ Source (child) column name.+ , fromDef :: FldDef' s -- ^ Type/nullability of @fromName@.+ , toName :: s -- ^ Target (parent) column name.+ , toDef :: FldDef' s -- ^ Type/nullability of @toName@.+ } deriving Show++genSingletons+ [ ''AggrFun, ''NameNS', ''TypDef', ''FldDef', ''TabDef', ''RelDef', ''RelType+ , ''RecField', ''Ref' ]++type NameNSK = NameNS' Symbol+type TypDefK = TypDef' Symbol+type FldDefK = FldDef' Symbol+type TabDefK = TabDef' Symbol+type RelDefK = RelDef' Symbol+type RecFieldK = RecField' Symbol+type RefK = Ref' Symbol++type NameNS = NameNS' Text+type TypDef = TypDef' Text+type FldDef = FldDef' Text+type TabDef = TabDef' Text+type RelDef = RelDef' Text++infixr 9 ->>+(->>) :: Text -> Text -> NameNS+(->>) = NameNS++type ns ->> name = 'NameNS ns name++type SimpleType c = 'TypDef c 'Nothing '[]++type family GetRelTab (froms :: [(NameNSK, RelDefK)])+ (tos :: [(NameNSK, RelDefK)]) (s :: Symbol) :: (NameNSK, RelType) where+ GetRelTab '[] '[] s = TypeError ('Text "No relation by name" ':$$: 'ShowType s)+ GetRelTab ('(a,b) ':xs) ys s =+ If (NnsName a == s) '(RdTo b, RelOne) (GetRelTab xs ys s)+ GetRelTab '[] ('(c,d) ':ys) s =+ If (NnsName c == s) '(RdFrom d, RelMany) (GetRelTab '[] ys s)++type family Elem' (x :: Symbol) (xs :: [Symbol]) :: Bool where+ Elem' x '[] = False+ Elem' x (x ': xs) = True+ Elem' x (y ': xs) = Elem' x xs++type IsMandatory fd = Not (FdNullable fd || FdHasDefault fd)+type IsMandatory' sch tab fld = IsMandatory (GetFldDef sch tab fld)++type family RestMandatory' sch t (rs :: [Symbol]) (fs :: [Symbol]) (res :: [Symbol]) :: [Symbol] where+ RestMandatory' sch t rs '[] res = res+ RestMandatory' sch t rs (fld ': fs) res = RestMandatory' sch t rs fs+ (If (IsMandatory' sch t fld && Not (Elem' fld rs)) (fld ': res) res)++type RestMandatory sch t rs = RestMandatory' sch t rs (TdFlds (TTabDef sch t)) '[]++type family RestPK' sch t (rs :: [Symbol]) (fs :: [Symbol]) (res :: [Symbol]) :: [Symbol] where+ RestPK' sch t rs '[] res = res+ RestPK' sch t rs (fld ': fs) res =+ RestPK' sch t rs fs (If (Not (Elem' fld rs)) (fld ': res) res)++type RestPK sch t rs = RestPK' sch t rs (TdKey (TTabDef sch t)) '[]++simpleType :: Text -> TypDef+simpleType c = TypDef c Nothing []++type SymNat = (Symbol, Nat)++type KnownSymNat sn = (SingI (NameSymNat sn))++nameSymNat :: forall sn -> KnownSymNat sn => Text+nameSymNat sn = demote @(NameSymNat sn)+-- >>> nameSymNat ("test", 42)+-- "test___42"++type family NameSymNat (sn :: SymNat) where+ NameSymNat '(s,0) = s+ NameSymNat '(s,n) = AppendSymbol s (AppendSymbol "___" (NatToSymbol n))++-- CTypDef+-- | instances will be generated by code generation+class+ (ToStar name, ToStar (TTypDef sch name)) => CTypDef sch (name :: NameNSK) where++ type TTypDef sch name :: TypDefK++-- | Schema-level field kind for (sch, tab, field name).+-- Instances are generated by codegen (Gen) or defined manually (e.g. Catalog).+class (ToStar (TDBFieldInfo sch tab name), ToStar tab, ToStar name)+ => CDBFieldInfo sch (tab :: NameNSK) (name :: Symbol) where+ type TDBFieldInfo sch tab name :: RecFieldK NameNSK++-- | Extract 'FldDefK' from a plain field kind (for conditions, order, etc.).+type family PlainFldDef (r :: RecFieldK NameNSK) :: FldDefK where+ PlainFldDef ('RFPlain fd) = fd++-- | Field definition for (sch, tab, name) when the field is plain. Used by Select/Update conditions.+type family GetFldDef (sch :: k) (tab :: NameNSK) (name :: Symbol) :: FldDefK where+ GetFldDef sch tab name = PlainFldDef (TDBFieldInfo sch tab name)++-- CTabDef+-- | instances will be generated by code generation+class (ToStar name, ToStar (TTabDef sch name)) => CTabDef sch (name::NameNSK) where+ type TTabDef sch name :: TabDefK++-- | Relation definition for relation name ref.+class+ ( ToStar (TRelDef sch ref)+ , CTabDef sch (RdFrom (TRelDef sch ref))+ , CTabDef sch (RdTo (TRelDef sch ref)) )+ => CRelDef sch (ref :: NameNSK) where+ type TRelDef sch (ref :: NameNSK) :: RelDefK++getFldDef :: forall sch t n. ToStar (TDBFieldInfo sch t n) => FldDef+getFldDef = case demote @(TDBFieldInfo sch t n) of+ RFPlain fd -> fd+ _ -> error "impossible"++class CTabRels sch (tab :: NameNSK) where+ type TFrom sch tab :: [NameNSK]+ type TTo sch tab :: [NameNSK]++genDefunSymbols [''TTypDef, ''TDBFieldInfo, ''GetFldDef, ''TTabDef, ''TRelDef, ''TFrom, ''TTo]++type family Map2 (f :: a ~> b) (xs :: [a]) :: [(a,b)] where+ Map2 f '[] = '[]+ Map2 f (x ': xs) = '(x, Apply f x) ': Map2 f xs++type family Map3 (f :: a ~> b) (g :: c ~> [a]) (xs :: [c]) :: [[(a,b)]] where+ Map3 f g '[] = '[]+ Map3 f g (x ': xs) = Map2 f (Apply g x) ': Map3 f g xs++type TTabRelFrom sch tab = Map2 (TRelDefSym1 sch) (TFrom sch tab)+type TTabRelTo sch tab = Map2 (TRelDefSym1 sch) (TTo sch tab)++-- | The main class for schema. All DML operations are based on this class.+-- It contains all the information about the schema: tables, relations, fields, types.+--+-- This class guarantees that we can demote all the necessary information about the schema from type level to value level.+--+-- Instances will be generated by code generation+class+ ( ToStar (TTabs sch)+ , ToStar (TTabRelFroms sch)+ , ToStar (TTabRelTos sch)+ , ToStar (TTabFldDefs sch)+ , ToStar (TTabFlds sch)+ , ToStar (TTabDefs sch)+ , ToStar (TTypes sch)+ , ToStar (Map1 (TTypDefSym1 sch) (TTypes sch))+ )+ => CSchema sch where++ type TTabs sch :: [NameNSK]+ type TTypes sch :: [NameNSK]++type TTabDefs sch = Map1 (TTabDefSym1 sch) (TTabs sch)+type TTabFlds sch = Map1 TdFldsSym0 (TTabDefs sch)++type family TTabFldDefsList sch (tabs :: [NameNSK]) (tabFlds :: [[Symbol]]) :: [[FldDefK]] where+ TTabFldDefsList sch '[] '[] = '[]+ TTabFldDefsList sch (t ': ts) (f ': fs) = Map1 (GetFldDefSym2 sch t) f ': TTabFldDefsList sch ts fs++type TTabFldDefs sch = TTabFldDefsList sch (TTabs sch) (TTabFlds sch)+type TTabRelFroms sch = Map3 (TRelDefSym1 sch) (TFromSym1 sch) (TTabs sch)+type TTabRelTos sch = Map3 (TRelDefSym1 sch) (TToSym1 sch) (TTabs sch)++--+data TabInfo = TabInfo+ { tiDef :: TabDef+ , tiFlds :: M.Map Text FldDef+ , tiFrom :: M.Map NameNS RelDef+ , tiTo :: M.Map NameNS RelDef }+ deriving Show++tabInfoMap :: forall sch. CSchema sch => M.Map NameNS TabInfo+tabInfoMap = M.fromList+ [ (tabName, tabInfo)+ | tabName <- demote @(TTabs sch)+ | tabInfo <-+ [ TabInfo{..}+ | tiDef <- demote @(TTabDefs sch)+ | tiFlds <-+ [ M.fromList $ L.zip fs ds+ | fs <- demote @(TTabFlds sch)+ | ds <- demote @(TTabFldDefs sch) ]+ | tiFrom <- M.fromList <$> demote @(TTabRelFroms sch)+ | tiTo <- M.fromList <$> demote @(TTabRelTos sch) ] ]++typDefMap :: forall sch. CSchema sch => M.Map NameNS TypDef+typDefMap = M.fromList $ L.zip+ (demote @(TTypes sch)) (demote @(Map1 (TTypDefSym1 sch) (TTypes sch)))++type TRelTab sch t name = GetRelTab+ (Map2 (TRelDefSym1 sch) (TFrom sch t)) (Map2 (TRelDefSym1 sch) (TTo sch t))+ name++type family TabOnPath2 sch (t :: NameNSK) (path :: [Symbol]) :: (NameNSK, RelType) where+ TabOnPath2 sch t '[] = '(t, 'RelMany)+ TabOnPath2 sch t '[x] = TRelTab sch t x+ TabOnPath2 sch t (x ': xs) = TabOnPath2 sch (Fst (TRelTab sch t x)) xs++type TabOnPath sch (t :: NameNSK) (path :: [Symbol]) = Fst (TabOnPath2 sch t path)++--+type family TabPath sch (t :: NameNSK) (path :: [Symbol]) :: Constraint where+ TabPath sch t '[] = ()+ TabPath sch t (x ': xs) = TabPath sch (Fst (TRelTab sch t x)) xs++type RecField = RecField' Text+type Ref = Ref' Text++-- | Value-level: whether any ref in the list has a nullable column.+-- Companion to type-level 'HasNullableRefs'.+hasNullableRefs :: [Ref] -> Bool+hasNullableRefs = L.any (fdNullable . fromDef)++qualName :: NameNS -> Text+qualName NameNS {..}+ | nnsNamespace == fromString "pg_catalog" = nnsName+ | otherwise = nnsNamespace <> fromString "." <> nnsName
+ src/PgSchema/Schema/Catalog.hs view
@@ -0,0 +1,345 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+{-# LANGUAGE UndecidableInstances #-}+{-| Internal module: a type-level description of @pg_catalog@ tables in PostgreSQL+(the system catalogs), as required by @pg-schema@ for code generation and queries.++Application code should not need this module: use your generated schema module and+the supported public entry points (e.g. "PgSchema.Generation" and "PgSchema.DML").++It remains in the package export list because of technical constraints (visibility of+types and instances for other components and tests). Do not treat it as a stable+public API, and avoid importing it directly unless you are maintaining custom codegen+or library extensions.+-}+module PgSchema.Schema.Catalog where++import Data.Text as T+import PgSchema.Schema+import GHC.TypeLits (Symbol)+import GHC.TypeError qualified as TE+import PgSchema.Utils.Internal++data PgCatalog++type PGC name = "pg_catalog" ->> name++pgc :: Text -> NameNS+pgc = ("pg_catalog" ->>)++------ tables ----------++-- attribute++instance CTabDef PgCatalog (PGC "pg_attribute") where+ type TTabDef PgCatalog (PGC "pg_attribute") =+ 'TabDef+ '["oid","attrelid","attname","atttypid","attnum","attnotnull","atthasdef"]+ '["oid"] '[ '["attrelid","attname"], '["attrelid","attnum"]]++-- class++instance CTabDef PgCatalog (PGC "pg_class") where+ type TTabDef PgCatalog (PGC "pg_class") =+ 'TabDef '["oid","relnamespace","relname","relkind"] '["oid"]+ '[ '["relnamespace","relname"]]++-- relkind char:+-- r = ordinary table, i = index, S = sequence, v = view, m = materialized view+-- , c = composite type, t = TOAST table, f = foreign table++-- constraint++instance CTabDef PgCatalog (PGC "pg_constraint") where+ type TTabDef PgCatalog (PGC "pg_constraint") =+ 'TabDef+ '["oid","connamespace","conname","contype","conrelid","confrelid"+ ,"conkey","confkey","confupdtypeid","confdeltypeid"]+ '["oid"] '[ '["connamespace","conname"]]++-- enum++instance CTabDef PgCatalog (PGC "pg_enum") where+ type TTabDef PgCatalog (PGC "pg_enum") =+ 'TabDef '["oid","enumtypid","enumlabel","enumsortorder"] '["oid"]+ '[ '["enumtypid","enumlabel"], '["enumtypid","enumsortorder"]]++-- namespace++instance CTabDef PgCatalog (PGC "pg_namespace") where+ type TTabDef PgCatalog (PGC "pg_namespace") =+ 'TabDef '["oid","nspname"] '["oid"] '[ '["nspname"]]++-- type++instance CTabDef PgCatalog (PGC "pg_type") where+ type TTabDef PgCatalog (PGC "pg_type") =+ 'TabDef '["oid","typnamespace","typname","typcategory","typelem"]+ '["oid"] '[ '["typnamespace","typname"]]+ -- typcategory Codes+ -- A - Array types+ -- B - Boolean types+ -- C - Composite types+ -- D - Date/time types+ -- E - Enum types+ -- G - Geometric types+ -- I - Network address types+ -- N - Numeric types+ -- P - Pseudo-types+ -- R - Range types+ -- S - String types+ -- T - Timespan types+ -- U - User-defined types+ -- V - Bit-string types+ -- X - unknown type++ -- in case of Array `typelem` is a type of element++---------- relations ---------++instance CRelDef PgCatalog (PGC "attribute__class") where+ type TRelDef PgCatalog (PGC "attribute__class") =+ 'RelDef (PGC "pg_attribute") (PGC "pg_class") '[ '("attrelid","oid")]+instance CRelDef PgCatalog (PGC "attribute__type") where+ type TRelDef PgCatalog (PGC "attribute__type") =+ 'RelDef (PGC "pg_attribute") (PGC "pg_type") '[ '("atttypid","oid")]+instance CRelDef PgCatalog (PGC "class__namespace") where+ type TRelDef PgCatalog (PGC "class__namespace") =+ 'RelDef (PGC "pg_class") (PGC "pg_namespace") '[ '("relnamespace","oid")]+instance CRelDef PgCatalog (PGC "constraint__class") where+ type TRelDef PgCatalog (PGC "constraint__class") =+ 'RelDef (PGC "pg_constraint") (PGC "pg_class") '[ '("conrelid","oid")]+instance CRelDef PgCatalog (PGC "constraint__fclass") where+ type TRelDef PgCatalog (PGC "constraint__fclass") =+ 'RelDef (PGC "pg_constraint") (PGC "pg_class") '[ '("confrelid","oid")]+instance CRelDef PgCatalog (PGC "constraint__namespace") where+ type TRelDef PgCatalog (PGC "constraint__namespace") =+ 'RelDef (PGC "pg_constraint") (PGC "pg_namespace") '[ '("connamespace","oid")]+instance CRelDef PgCatalog (PGC "enum__type") where+ type TRelDef PgCatalog (PGC "enum__type") =+ 'RelDef (PGC "pg_enum") (PGC "pg_type") '[ '("enumtypid","oid")]+instance CRelDef PgCatalog (PGC "type__namespace") where+ type TRelDef PgCatalog (PGC "type__namespace") =+ 'RelDef (PGC "pg_type") (PGC "pg_namespace") '[ '("typnamespace","oid")]++----------- CTabRels ---------+instance CTabRels PgCatalog (PGC "pg_attribute") where+ type TFrom PgCatalog (PGC "pg_attribute") =+ '[PGC "attribute__class", PGC "attribute__type"]+ type TTo PgCatalog (PGC "pg_attribute") = '[]++instance CTabRels PgCatalog (PGC "pg_class") where+ type TFrom PgCatalog (PGC "pg_class") = '[PGC "class__namespace"]+ type TTo PgCatalog (PGC "pg_class") = '[PGC "attribute__class"+ , PGC "constraint__class", PGC "constraint__fclass"]++instance CTabRels PgCatalog (PGC "pg_constraint") where+ type TFrom PgCatalog (PGC "pg_constraint") =+ '[PGC "constraint__class", PGC "constraint__fclass", PGC "constraint__namespace"]+ type TTo PgCatalog (PGC "pg_constraint") = '[]++instance CTabRels PgCatalog (PGC "pg_enum") where+ type TFrom PgCatalog (PGC "pg_enum") = '[PGC "enum__type"]+ type TTo PgCatalog (PGC "pg_enum") = '[]++instance CTabRels PgCatalog (PGC "pg_namespace") where+ type TFrom PgCatalog (PGC "pg_namespace") = '[]+ type TTo PgCatalog (PGC "pg_namespace") =+ '[PGC "type__namespace", PGC "class__namespace", PGC "constraint__namespace"]++instance CTabRels PgCatalog (PGC "pg_type") where+ type TFrom PgCatalog (PGC "pg_type") = '[PGC "type__namespace"]+ type TTo PgCatalog (PGC "pg_type") = '[PGC "enum__type", PGC "attribute__type"]++----------- schema ----------++instance CSchema PgCatalog where+ -- type TSchema PgCatalog = "pg_catalog"++ type TTabs PgCatalog =+ '[ PGC "pg_attribute", PGC "pg_class", PGC "pg_constraint", PGC "pg_enum"+ , PGC "pg_namespace", PGC "pg_type" ]++ type TTypes PgCatalog =+ '[PGC "oid",PGC "int2",PGC "int2[]",PGC "float4",PGC "bool",PGC "name"+ ,PGC "char"]++instance CTypDef PgCatalog (PGC "oid") where+ type TTypDef PgCatalog (PGC "oid") = SimpleType "N"++instance CTypDef PgCatalog (PGC "int2") where+ type TTypDef PgCatalog (PGC "int2") = SimpleType "N"++instance CTypDef PgCatalog (PGC "int2[]") where+ type TTypDef PgCatalog (PGC "int2[]") = 'TypDef "A" (Just (PGC "int2")) '[]++instance CTypDef PgCatalog (PGC "float4") where+ type TTypDef PgCatalog (PGC "float4") = SimpleType "N"++instance CTypDef PgCatalog (PGC "bool") where+ type TTypDef PgCatalog (PGC "bool") = SimpleType "B"++instance CTypDef PgCatalog (PGC "name") where+ type TTypDef PgCatalog (PGC "name") = SimpleType "S"++instance CTypDef PgCatalog (PGC "char") where+ type TTypDef PgCatalog (PGC "char") = SimpleType "S"++---------- CDBFieldInfo ----------++-- Closed type family for PgCatalog field info+type family TDBFieldInfoPgCatalog (t :: NameNSK) (f :: Symbol)+ :: RecFieldK NameNSK where+ -- plain oid column for all catalog tables+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_class") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_enum") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_namespace") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_type") "oid" =+ 'RFPlain ('FldDef (PGC "oid") False False)++ -- pg_attribute+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attrelid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attname" =+ 'RFPlain ('FldDef (PGC "name") False False)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "atttypid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attnum" =+ 'RFPlain ('FldDef (PGC "int2") False False)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attnotnull" =+ 'RFPlain ('FldDef (PGC "bool") False False)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "atthasdef" =+ 'RFPlain ('FldDef (PGC "bool") False False)++ -- pg_class+ TDBFieldInfoPgCatalog (PGC "pg_class") "relnamespace" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_class") "relname" =+ 'RFPlain ('FldDef (PGC "name") False False)+ TDBFieldInfoPgCatalog (PGC "pg_class") "relkind" =+ 'RFPlain ('FldDef (PGC "char") False False)++ -- pg_constraint+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "connamespace" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "conname" =+ 'RFPlain ('FldDef (PGC "name") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "contype" =+ 'RFPlain ('FldDef (PGC "char") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "conrelid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "confrelid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "confupdtypeid" =+ 'RFPlain ('FldDef (PGC "bool") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "confdeltypeid" =+ 'RFPlain ('FldDef (PGC "bool") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "conkey" =+ 'RFPlain ('FldDef (PGC "int2[]") False False)+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "confkey" =+ 'RFPlain ('FldDef (PGC "int2[]") False False)++ -- pg_enum+ TDBFieldInfoPgCatalog (PGC "pg_enum") "enumtypid" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_enum") "enumlabel" =+ 'RFPlain ('FldDef (PGC "name") False False)+ TDBFieldInfoPgCatalog (PGC "pg_enum") "enumsortorder" =+ 'RFPlain ('FldDef (PGC "float4") False False)++ -- pg_namespace+ TDBFieldInfoPgCatalog (PGC "pg_namespace") "nspname" =+ 'RFPlain ('FldDef (PGC "name") False False)++ -- pg_type+ TDBFieldInfoPgCatalog (PGC "pg_type") "typnamespace" =+ 'RFPlain ('FldDef (PGC "oid") False False)+ TDBFieldInfoPgCatalog (PGC "pg_type") "typname" =+ 'RFPlain ('FldDef (PGC "name") False False)+ TDBFieldInfoPgCatalog (PGC "pg_type") "typcategory" =+ 'RFPlain ('FldDef (PGC "char") False False)+ TDBFieldInfoPgCatalog (PGC "pg_type") "typelem" =+ 'RFPlain ('FldDef (PGC "oid") False False)++ -- Relation names (RFFromHere / RFToHere)+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attribute__class" =+ 'RFFromHere (PGC "pg_class")+ '[ 'Ref "attrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_attribute") "attribute__type" =+ 'RFFromHere (PGC "pg_type")+ '[ 'Ref "atttypid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_class") "attribute__class" =+ 'RFToHere (PGC "pg_attribute")+ '[ 'Ref "attrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_class") "class__namespace" =+ 'RFFromHere (PGC "pg_namespace")+ '[ 'Ref "relnamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_class") "constraint__class" =+ 'RFToHere (PGC "pg_constraint")+ '[ 'Ref "conrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_class") "constraint__fclass" =+ 'RFToHere (PGC "pg_constraint")+ '[ 'Ref "confrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]++ TDBFieldInfoPgCatalog (PGC "pg_constraint") "constraint__class" =+ 'RFFromHere (PGC "pg_class")+ '[ 'Ref "conrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "constraint__fclass" =+ 'RFFromHere (PGC "pg_class")+ '[ 'Ref "confrelid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_constraint") "constraint__namespace" =+ 'RFFromHere (PGC "pg_namespace")+ '[ 'Ref "connamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]++ TDBFieldInfoPgCatalog (PGC "pg_enum") "enum__type" =+ 'RFFromHere (PGC "pg_type")+ '[ 'Ref "enumtypid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_type") "enum__type" =+ 'RFToHere (PGC "pg_enum")+ '[ 'Ref "enumtypid" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]++ TDBFieldInfoPgCatalog (PGC "pg_type") "type__namespace" =+ 'RFFromHere (PGC "pg_namespace")+ '[ 'Ref "typnamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_namespace") "type__namespace" =+ 'RFToHere (PGC "pg_type")+ '[ 'Ref "typnamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_namespace") "class__namespace" =+ 'RFToHere (PGC "pg_class")+ '[ 'Ref "relnamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]+ TDBFieldInfoPgCatalog (PGC "pg_namespace") "constraint__namespace" =+ 'RFToHere (PGC "pg_constraint")+ '[ 'Ref "connamespace" ('FldDef (PGC "oid") False False)+ "oid" ('FldDef (PGC "oid") False False) ]++ -- default: error+ TDBFieldInfoPgCatalog t f =+ TE.TypeError+ (TE.Text "In schema PgCatalog for table "+ TE.:<>: TE.ShowType t+ TE.:<>: TE.Text " field "+ TE.:<>: TE.ShowType f+ TE.:<>: TE.Text " is not defined")++instance (ToStar (TDBFieldInfoPgCatalog t f), ToStar t, ToStar f) => CDBFieldInfo PgCatalog t f where+ type TDBFieldInfo PgCatalog t f = TDBFieldInfoPgCatalog t f
+ src/PgSchema/Schema/Info.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE UndecidableInstances #-}+{-| Internal module: ordinary (term-level) ADTs matching the shape of rows returned+when querying PostgreSQL system catalogs during schema introspection.++This is not part of the application-facing @pg-schema@ API; these types are used+in the generation pipeline and in internal plumbing. Application code should not+import this module: field layout may change together with the generator.++The module appears in the package export list for technical reasons (tests, shared+dependencies, hidden modules). Do not rely on it as a library compatibility boundary.+-}+module PgSchema.Schema.Info where++import Data.Text as T+import GHC.Generics+import GHC.Int+import PgSchema.Types+++-- | Tables and views info+data PgClass = PgClass+ { class__namespace :: "nspname" := Text+ , relname :: Text+ , relkind :: PgChar+ , attribute__class :: [PgAttribute]+ , constraint__class :: [PgConstraint] }+ deriving (Show,Eq,Generic)++data PgClassShort = PgClassShort+ { class__namespace :: "nspname" := Text+ , relname :: Text }+ deriving (Show,Eq,Generic)++data PgAttribute = PgAttribute+ { attname :: Text+ , attribute__type :: PgType+ , attnum :: Int16+ , attnotnull :: Bool+ , atthasdef :: Bool }+ deriving (Show,Eq,Generic)++data PgConstraint = PgConstraint+ { constraint__namespace :: "nspname" := Text+ , conname :: Text+ , contype :: PgChar+ , conkey :: PgArr Int16 }+ deriving (Show,Eq,Generic)++-- | Types info+data PgType = PgType+ { oid :: PgOid+ , type__namespace :: "nspname" := Text+ , typname :: Text+ , typcategory :: PgChar+ , typelem :: PgOid+ , enum__type :: [PgEnum] }+ deriving (Show,Eq,Generic)++--+data PgEnum = PgEnum+ { enumlabel :: Text+ , enumsortorder :: Double }+ deriving (Show,Eq,Generic)++-- | Foreign key info+data PgRelation = PgRelation+ { constraint__namespace :: "nspname" := Text+ , conname :: Text+ , constraint__class :: PgClassShort+ , constraint__fclass :: PgClassShort+ , conkey :: PgArr Int16+ , confkey :: PgArr Int16 }+ deriving (Show,Eq,Generic)
+ src/PgSchema/Types.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+module PgSchema.Types(+ -- * PgTag types+ type (:=), (=:), (:.)(..), PgTag(..)+ -- * Enum+ , PGEnum+ -- * Aggregates+ , Aggr(..), Aggr'(..)+ -- * Arrays+ , PgArr(..), pgArr', unPgArr'+ -- * Other types+ , PgChar(..), PgOid(..)+ -- * Conversion checks+ , CanConvert, CanConvert1)+ where++import Control.Monad+import Data.Aeson+import Data.ByteString as BS+import Data.ByteString.Lazy as BSL+import Data.CaseInsensitive+import Data.Coerce+import Data.Fixed+import Data.Kind+import Data.List qualified as L+import Data.Maybe+import Data.Scientific+import Data.Singletons.TH+import Data.Text as T+import Data.Text.Encoding as T+import Data.Time+import Data.UUID.Types+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField+import Database.PostgreSQL.Simple.Types+import GHC.TypeLits as TL+import GHC.TypeError as TE+import Data.Type.Equality (type (==))+import GHC.Int+import Prelude as P+import Type.Reflection+import PgSchema.Schema.Catalog (PGC)+import Data.Type.Bool (Not, type (&&), type (||))+import PgSchema.Schema+import PgSchema.Utils.Internal hiding (fromText)+++#ifdef MK_ARBITRARY+import Test.QuickCheck(Arbitrary(arbitrary), arbitraryBoundedEnum)+#endif+#ifdef MK_FLAT+import Flat as F+#endif+#ifdef MK_HASHABLE+import Data.Hashable+#endif+++-- | Introduce `enum` database types.+-- Data instances are produced by schema generation.+-- You can use these data instances in you records to @SELECT@/@INSERT@/@UPSERT@ data+data family PGEnum sch (name :: NameNSK) :: Type++instance+ (Read (PGEnum sch n), ToStar n, Typeable sch, Typeable n)+ => FromField (PGEnum sch n) where+ fromField f mbs =+ case mbs >>= enumFromText . decodeUtf8 of+ Just x -> pure x+ _ -> returnError Incompatible f ""++instance+ (Show (PGEnum sch n), ToStar n) => ToField (PGEnum sch n) where+ toField = toField . enumToText++instance (Read (PGEnum sch t), ToStar t) => FromJSON (PGEnum sch t) where+ parseJSON = parseJSON >=> maybe mzero pure . enumFromText++instance (Show (PGEnum sch t), ToStar t) => ToJSON (PGEnum sch t) where+ toJSON = toJSON . enumToText++enumFromText+ :: forall sch t. (Read (PGEnum sch t), ToStar t)+ => Text -> Maybe (PGEnum sch t)+enumFromText t = fmap fst $ listToMaybe+ $ reads $ T.unpack $ toTitle (nnsName $ demote @t) <> "_" <> t++enumToText :: forall sch t. (Show (PGEnum sch t), ToStar t) => PGEnum sch t -> Text+enumToText = T.drop (T.length (nnsName $ demote @t) + 1) . T.show++#ifdef MK_ARBITRARY+instance (Bounded (PGEnum sch t), Enum (PGEnum sch t)) =>+ Arbitrary (PGEnum sch t) where+ arbitrary = arbitraryBoundedEnum+#endif++#ifdef MK_FLAT+instance (Read (PGEnum sch n), Show (PGEnum sch n)) => Flat (PGEnum sch n) where+ encode = F.encode . P.show+ decode = read <$> F.decode+ size = F.size . P.show+#endif++-- | Introduce aggregate functions.+--+-- I.e. @"fld" := Aggr AMin (Maybe Int32)@ means "minimum value of the field `fld`"+--+-- 'Aggr' requires a 'Maybe' argument for all functions except @count@.+--+-- Only a small set of aggregations are supported currently: @count@, @min@, @max@, @sum@, @avg@.+newtype Aggr (f :: AggrFun) t = Aggr { unAggr :: t }+ deriving stock Show+ deriving newtype (Eq, Ord, FromField, ToField, FromJSON, ToJSON)++-- | All aggregate functions except @count@ can return NULL.+-- But if field under aggregate is mandatory they return NULL only on empty set+-- if there is no group by clause. E.g. `select min(a) from t where false`+-- So we require Nullable for Aggr.+--+-- 'Aggr'' is like 'Aggr' but cannot be used in SELECT without `group by`.+-- So it is mandatory if field is mandatory.+newtype Aggr' (f :: AggrFun) t = Aggr' { unAggr' :: t }+ deriving stock Show+ deriving newtype (Eq, Ord, FromField, ToField, FromJSON, ToJSON)++-- | 'Char' has no 'ToField' instance; this is a custom wrapper.+newtype PgChar = PgChar { unPgChar :: Char }+ deriving stock (Show, Read)+ deriving newtype (Eq, Ord, FromField, Enum, Bounded, FromJSON, ToJSON+#ifdef MK_HASHABLE+ , Hashable )+#else+ )+#endif++instance ToField PgChar where+ toField = toField . (:[]) . unPgChar++--+-- | 'PGArray' has no JSON instances. '[]' has JSON, but no PG instances.+-- This one has both.+--+-- Use this type to work with arrays in database.+--+-- All elements are 'Maybe' because PostgreSQL does not guarantee that all elements are present.+-- 'PgTag' @typeName@ 'PgArr' can be /safely/ converted to 'ToField' with type information (e.g. @val::int[]@).+-- This instance is used internally in the generation of SQL.+--+newtype PgArr a = PgArr { unPgArr :: [Maybe a] }+ deriving stock (Show, Read)+ deriving newtype (Eq, Ord, FromJSON, ToJSON, Semigroup, Monoid+#ifdef MK_HASHABLE+ , Hashable )+#else+ )+#endif+#ifdef MK_ARBITRARY+ deriving newtype Arbitrary+#endif+#ifdef MK_FLAT+ deriving newtype Flat+#endif++instance (FromField a, Typeable a) => FromField (PgTag s (PgArr a)) where+ fromField = (fmap (coerce @(PGArray (Maybe a))) .) . fromField++instance (ToField a, ToStar s) => ToField (PgTag (s :: Maybe NameNSK) (PgArr a)) where+ toField (PgTag (PgArr xs)) =+ case toField (PGArray xs) of+ Plain b -> Plain (b <> typ)+ Many zs -> Many (zs <> [Plain typ])+ x -> x+ where+ typ = encodeUtf8Builder $ maybe mempty (("::" <>) . (<> "[]") . qualName) $ demote @s++instance ToJSON a => ToJSON (PgTag (s :: Maybe NameNSK) (PgArr a)) where+ toJSON = toJSON . unPgTag++instance FromJSON a => FromJSON (PgTag (s :: Maybe NameNSK) (PgArr a)) where+ parseJSON = fmap PgTag . parseJSON++-- | Make 'PgArr' from list. All elements are lifted to 'Maybe'+pgArr' :: [a] -> PgArr a+pgArr' = PgArr . fmap Just++-- | Make list from 'PgArr'. All empty ('Nothing') elements are omitted.+unPgArr' :: PgArr a -> [a]+unPgArr' = catMaybes . unPgArr++-- | 'Oid' but with JSON instances+newtype PgOid = PgOid { fromPgOid :: Oid }+ deriving stock (Show, Read)+ deriving newtype (FromField, ToField)++instance Eq PgOid where _ == _ = True+ -- we don't want to distinguish by OIDs but by names instead+ -- e.g. if we recreate some table or constraint++instance FromJSON PgOid where+ parseJSON = fmap (PgOid . read . ("Oid " ++)) . parseJSON++instance ToJSON PgOid where+ toJSON = toJSON . L.drop 4 . P.show . fromPgOid++-- | Closed type family to check that field can be converted to or from Haskell type.+-- To make your types convertible to some database type use open type family 'CanConvert1'.+type family CanConvert sch (tab :: NameNSK) (fld::Symbol) (fd :: FldDefK) (t :: Type) :: Constraint where+ CanConvert sch tab fld fd t = CanConvertMaybe sch tab fld (FdType fd)+ (FdNullable fd) (TTypDef sch (FdType fd)) t++type ErrDesc tab fld tn t =+ ( TL.Text ""+ :$$: TL.Text "Table: " :<>: TL.ShowType tab+ :$$: TL.Text "DB Field name: " :<>: TL.ShowType fld+ :$$: TL.Text "DB Field type: " :<>: TL.ShowType tn+ :$$: TL.Text "Haskell Field type: " :<>: TL.ShowType t+ :$$: TL.Text "")++type ErrWithHead s tab fld tn t = TL.TypeError (TL.Text s :$$: ErrDesc tab fld tn t)++type family GuardConvert (ok :: Bool) sch tab fld tn td t t' err :: Constraint where+ GuardConvert 'True sch tab fld tn td t t' err = CanConvert1 sch tab fld tn td t'+ GuardConvert 'False sch tab fld tn td t t' err = ErrWithHead err tab fld tn t++type family CanConvertMaybe sch (tab::NameNSK) (fld::Symbol) (tn::NameNSK)+ (nullable :: Bool) (td :: TypDefK) (t :: Type) :: Constraint where+ CanConvertMaybe sch tab fld tn nullable td (Maybe (Aggr fn t)) =+ ErrWithHead "You can't use Maybe for aggregates. Use Maybe inside Aggr"+ tab fld tn (Aggr fn t)+ CanConvertMaybe sch tab fld tn nullable td (Maybe (Aggr' fn t)) =+ ErrWithHead "You can't use Maybe for aggregates. Use Maybe inside Aggr'"+ tab fld tn (Aggr' fn t)+ CanConvertMaybe sch tab fld tn nullable td (Maybe t) = GuardConvert+ nullable sch tab fld tn td (Maybe t) t "You can't use Maybe for mandatory fields"+ -- aggregates --+ -- ACount<=>int64; AMin/AMax<=>N,S,B,D; ASum<=>N+int*->Int64|Double; AAvg<=>N+float8+ CanConvertMaybe sch tab fld tn nullable td (Aggr ACount Int64) = ()+ CanConvertMaybe sch tab fld tn nullable td (Aggr ACount t) =+ ErrWithHead "You have to use Int64 for Aggr ACount fields" tab fld tn t+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ACount Int64) = ()+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ACount t) =+ ErrWithHead "You have to use Int64 for Aggr' ACount fields" tab fld tn t+ CanConvertMaybe sch tab fld tn nullable td (Aggr AMin t) = GuardConvert+ (IsMaybe t && Elem' (TypCategory td) '["N","S","B","D"])+ sch tab fld tn td (Aggr AMin t) (UnMaybe t)+ "'Aggr AMin' is possible only for 'Maybe' values and numeric, text, bool or date fields"+ CanConvertMaybe sch tab fld tn nullable td (Aggr' AMin t) = GuardConvert+ (Elem' (TypCategory td) '["N","S","B","D"]) sch tab fld tn td (Aggr' AMin t) t+ "'Aggr' AMin' is possible only for numeric, text, bool or date fields"+ CanConvertMaybe sch tab fld tn nullable td (Aggr AMax t) = GuardConvert+ (IsMaybe t && Elem' (TypCategory td) '["N","S","B","D"])+ sch tab fld tn td (Aggr AMax t) (UnMaybe t)+ "'Aggr AMax' is possible only for 'Maybe' values and numeric, text, bool or date fields"+ CanConvertMaybe sch tab fld tn nullable td (Aggr' AMax t) = GuardConvert+ (Elem' (TypCategory td) '["N","S","B","D"])+ sch tab fld tn td (Aggr' AMax t) t+ "'Aggr' AMax' is possible only for numeric, text, bool or date fields"+ CanConvertMaybe sch tab fld tn nullable td (Aggr AAvg (Maybe Scientific)) =+ Assert (TypCategory td == "N") (ErrWithHead+ "'Aggr AAvg' is possible only for numeric fields"+ tab fld tn (Aggr AAvg (Maybe Scientific)))+ CanConvertMaybe sch tab fld tn nullable td (Aggr AAvg t) = ErrWithHead+ "You have to use `Maybe Scientific` for `Aggr AAvg` fields"+ tab fld tn (Aggr AAvg t)+ CanConvertMaybe sch tab fld tn nullable td (Aggr' AAvg (Maybe Scientific)) =+ Assert (TypCategory td == "N" && nullable) (ErrWithHead+ "'Aggr' AAvg (Maybe Scientific)' is possible only for nullable numeric fields"+ tab fld tn (Aggr' AAvg (Maybe Scientific)))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' AAvg Scientific) =+ Assert (TypCategory td == "N" && Not nullable) (ErrWithHead+ "'Aggr' AAvg Scientific' is possible only for mandatory numeric fields"+ tab fld tn (Aggr' AAvg Scientific))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' AAvg t) = ErrWithHead+ "You have to use `Scientific` (or `Maybe Scientific`) for `Aggr' AAvg` fields"+ tab fld tn (Aggr' AAvg t)+ CanConvertMaybe sch tab fld tn nullable td (Aggr ASum (Maybe Int64)) =+ ( Assert (TypCategory td == "N" && (NnsName tn == "int2" || NnsName tn == "int4"))+ (ErrWithHead "'Aggr ASum (Maybe Int64)' is possible only for 'int2/int4' fields"+ tab fld tn (Aggr ASum (Maybe Int64))))+ CanConvertMaybe sch tab fld tn nullable td (Aggr ASum (Maybe Scientific)) =+ ( Assert (TypCategory td == "N")+ (ErrWithHead "'Aggr ASum (Maybe Scientific)' is possible only for numeric fields"+ tab fld tn (Aggr ASum (Maybe Scientific))))+ CanConvertMaybe sch tab fld tn nullable td (Aggr ASum t) = ErrWithHead+ "You have to use `Maybe Int64` (or `Maybe Scientific`) for `Aggr ASum` fields"+ tab fld tn (Aggr ASum t)+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ASum (Maybe Int64)) =+ ( Assert (nullable && TypCategory td == "N" && (NnsName tn == "int2" || NnsName tn == "int4"))+ (ErrWithHead "'Aggr' ASum (Maybe Int64)' is possible only for nullable 'int2/int4' fields"+ tab fld tn (Aggr' ASum (Maybe Int64))))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ASum (Maybe Scientific)) =+ ( Assert (nullable && TypCategory td == "N")+ (ErrWithHead "'Aggr' ASum (Maybe Scientific)' is possible only for nullable numeric fields"+ tab fld tn (Aggr' ASum (Maybe Scientific))))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ASum Int64) =+ ( Assert (Not nullable && TypCategory td == "N" && (NnsName tn == "int2" || NnsName tn == "int4"))+ (ErrWithHead "'Aggr' ASum Int64' is possible only for mandatory 'int2/int4' fields"+ tab fld tn (Aggr' ASum Int64)))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ASum Scientific) =+ ( Assert (Not nullable && TypCategory td == "N")+ (ErrWithHead "'Aggr' ASum (Scientific)' is possible only for mandatory numeric fields"+ tab fld tn (Aggr' ASum Scientific)))+ CanConvertMaybe sch tab fld tn nullable td (Aggr' ASum t) = ErrWithHead+ "You have to use `[Maybe] Int64` (or `[Maybe] Scientific`) for `Aggr' ASum` fields"+ tab fld tn (Aggr' ASum t)+ -- end aggregates --+ CanConvertMaybe sch tab fld tn nullable td t = GuardConvert (Not nullable)+ sch tab fld tn td t t "You have to use Maybe for nullable fields"++-- | Open mapping from a PostgreSQL type (non-nullable) to a Haskell type.+-- Add your own equations to this family to support extra pairings.+type family CanConvert1 sch (tab::NameNSK) (fld::Symbol) (tn::NameNSK) (td::TypDefK) t :: Constraint++type instance CanConvert1 sch tab fld tn ('TypDef "A" ('Just n) y) (PgArr t) =+ CanConvert1 sch tab fld n (TTypDef sch n) t++type instance CanConvert1 sch tab fld tn ('TypDef "B" x y) Bool = ()+type instance CanConvert1 sch tab fld (PGC "int2") ('TypDef "N" x y) Int16 = ()+type instance CanConvert1 sch tab fld (PGC "int4") ('TypDef "N" x y) Int32 = ()+type instance CanConvert1 sch tab fld (PGC "int8") ('TypDef "N" x y) Int64 = ()+type instance CanConvert1 sch tab fld (PGC "float4") ('TypDef "N" x y) Double = ()+type instance CanConvert1 sch tab fld (PGC "float8") ('TypDef "N" x y) Double = ()+-- type instance CanConvert1 sch tab fld (PGC "numeric") ('TypDef "N" x y) Double = ()+type instance CanConvert1 sch tab fld (PGC "oid") ('TypDef "N" x y) Int = ()+type instance CanConvert1 sch tab fld (PGC "numeric") ('TypDef "N" x y) (Fixed k) = () -- unsafe!+type instance CanConvert1 sch tab fld (PGC "int2") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "int4") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "int8") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "float4") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "float8") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "numeric") ('TypDef "N" x y) Scientific = ()+type instance CanConvert1 sch tab fld (PGC "oid") ('TypDef "N" x y) PgOid = ()++type instance CanConvert1 sch tab fld (PGC "date") ('TypDef "D" x y) Day = ()+type instance CanConvert1 sch tab fld (PGC "time") ('TypDef "D" x y) TimeOfDay = ()+type instance CanConvert1 sch tab fld (PGC "timestamp") ('TypDef "D" x y) LocalTime = ()+type instance CanConvert1 sch tab fld (PGC "timestamptz") ('TypDef "D" x y) ZonedTime = ()+type instance CanConvert1 sch tab fld (PGC "timestamptz") ('TypDef "D" x y) UTCTime = ()++type instance CanConvert1 sch tab fld (PGC "char") ('TypDef "S" x y) PgChar = ()+type instance CanConvert1 sch tab fld (PGC "text") ('TypDef "S" x y) Text = ()+type instance CanConvert1 sch tab fld (PGC "varchar") ('TypDef "S" x y) Text = ()+type instance CanConvert1 sch tab fld (PGC "name") ('TypDef "S" x y) Text = ()+type instance CanConvert1 sch tab fld (PGC "citext") ('TypDef "S" Nothing '[]) (CI Text) = ()+type instance CanConvert1 sch tab fld ("public" ->> "citext") ('TypDef "S" Nothing '[]) (CI Text) = ()+type instance CanConvert1 sch tab fld (PGC "bytea") ('TypDef "U" x y) (Binary BS.ByteString) = ()+type instance CanConvert1 sch tab fld (PGC "bytea") ('TypDef "U" x y) (Binary BSL.ByteString) = ()+-- ^ Binary ByteString has no 'FromJSON'/'ToJSON' instances, so it can+-- be used only in the root table.+type instance CanConvert1 sch tab fld (PGC "jsonb") ('TypDef "U" x y) a = (FromJSON a, ToJSON a)+type instance CanConvert1 sch tab fld (PGC "json") ('TypDef "U" x y) a = (FromJSON a, ToJSON a)+type instance CanConvert1 sch tab fld (PGC "uuid") ('TypDef "U" x y) UUID = ()++type instance CanConvert1 sch tab fld n ('TypDef "E" 'Nothing es) (PGEnum sch n)+ = ( TTypDef sch n ~ 'TypDef "E" 'Nothing es+ , FromJSON (PGEnum sch n)+ , ToJSON (PGEnum sch n) )++-- | Annotates a value with schema/type information for DML codecs.+--+-- You can describe rows in two ways:+--+-- 1. Ordinary Haskell records with a 'GHC.Generics.Generic' instance.+-- 2. Symbol-labelled rows built from '(=:)' and chained with '(:.)' from+-- @postgresql-simple@ (re-exported from "PgSchema.DML").+--+-- 'PgTag' is analogous to 'Data.Tagged.Tagged' from the @tagged@ package, but+-- carries JSON (and related) instances suited to @pg-schema@.+--+-- Both representations can be mixed in one row.+--+-- Two pieces of syntax cooperate with 'PgTag':+--+-- * '(=:)' builds a 'PgTag' value (field name + payload).+-- @RequiredTypeArguments@ lets you avoid noisy explicit type application on the+-- field name: you write "name" =: "John" instead of @"name" =: "John".+-- * '(:=)' is the type-level spelling of the same idea (see the '(:=)' type+-- synonym below).+--+newtype PgTag s t = PgTag { unPgTag :: t }+ deriving stock (Show, Read, Eq, Ord, Functor, Foldable, Traversable)+ deriving newtype (Semigroup, Monoid)++type s := t = PgTag s t+infixr 5 :=++(=:) :: forall b. forall a -> b -> a := b+(=:) _ = coerce+infixr 5 =:
+ src/PgSchema/Utils/CamelToSnake.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE UndecidableInstances #-}+module PgSchema.Utils.CamelToSnake(type CamelToSnake) where++import GHC.TypeLits+import Data.Type.Bool+import Data.Type.Equality+++-- | Closed type family to convert CamelCase to snake_case that can be used in 'Renamer'.+--+-- @+-- >>> import Data.Proxy+-- >>> symbolVal (Proxy @(CamelToSnake "TESTCamelTo_snake_Case"))+-- "t_e_s_t_camel_to_snake__case"+--+-- @+type CamelToSnake (s :: Symbol) = CamelToSnakeInternal (UnconsSymbol s)++type family CamelToSnakeInternal (m :: Maybe (Char, Symbol)) :: Symbol where+ CamelToSnakeInternal 'Nothing = ""+ CamelToSnakeInternal ('Just '(c, s)) =+ AppendSymbol (ConsSymbol (ToLower c) "") (SnakeLoop (UnconsSymbol s))++type family SnakeLoop (m :: Maybe (Char, Symbol)) :: Symbol where+ SnakeLoop 'Nothing = ""+ SnakeLoop ('Just '(c, s)) =+ AppendSymbol (ProcessChar c) (SnakeLoop (UnconsSymbol s))++type ProcessChar c = If (IsUpper c)+ (AppendSymbol "_" (ConsSymbol (ToLower c) ""))+ (ConsSymbol c "")++type IsUpper (c :: Char) = Not ((CmpChar c 'A' == 'LT) || (CmpChar c 'Z' == 'GT))++type ToLower (c :: Char) = If (IsUpper c) (NatToChar (CharToNat c + 32)) c
+ src/PgSchema/Utils/Instances.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module PgSchema.Utils.Instances where++import Data.Kind (Type)+import Data.Singletons+import Data.Text as T+import GHC.TypeLits+++-- * Bool singletons (avoid "Data.Bool.Singletons" from singletons-base)++data SBool :: Bool -> Type where+ SFalse :: SBool 'False+ STrue :: SBool 'True++type instance Sing @Bool = SBool++instance SingKind Bool where+ type Demote Bool = Bool+ fromSing SFalse = False+ fromSing STrue = True+ toSing False = SomeSing SFalse+ toSing True = SomeSing STrue++instance SingI 'False where sing = SFalse++instance SingI 'True where sing = STrue++-- * Maybe singletons (avoid "Data.Maybe.Singletons" from singletons-base)++data SMaybe :: Maybe k -> Type where+ SNothing :: SMaybe 'Nothing+ SJust :: Sing x -> SMaybe ('Just x)++type instance Sing @(Maybe k) = SMaybe++instance SingKind k => SingKind (Maybe k) where+ type Demote (Maybe k) = Maybe (Demote k)+ fromSing SNothing = Nothing+ fromSing (SJust sx) = Just (fromSing sx)+ toSing Nothing = SomeSing SNothing+ toSing (Just x) = case toSing x of+ SomeSing sx -> SomeSing (SJust sx)++instance SingI 'Nothing where+ sing = SNothing++instance SingI x => SingI ('Just x) where+ sing = SJust sing++-- * @Symbol@ singletons (@Demote Symbol = Text@, as in @pg-schema@)++type instance Sing @Symbol = SSymbol++instance SingKind Symbol where+ type Demote Symbol = Text+ fromSing (SSymbol :: SSymbol n) = T.pack (symbolVal (Proxy @n))+ toSing t = case someSymbolVal (T.unpack t) of+ SomeSymbol (_ :: Proxy n) -> SomeSing (SSymbol @n)++instance KnownSymbol n => SingI n where+ sing = SSymbol++-- * List singletons++data SList :: [k] -> Type where+ SNil :: SList '[]+ SCons :: Sing x -> Sing xs -> SList (x ': xs)++type instance Sing @[k] = SList++instance SingKind k => SingKind [k] where+ type Demote [k] = [Demote k]+ fromSing SNil = []+ fromSing (SCons sx sxs) = fromSing sx : fromSing sxs+ toSing [] = SomeSing SNil+ toSing (x : xs) = case (toSing x, toSing xs) of+ (SomeSing sx, SomeSing sxs) -> SomeSing (SCons sx sxs)++instance SingI '[] where+ sing = SNil++instance (SingI x, SingI xs) => SingI (x ': xs) where+ sing = SCons sing sing++-- * Pair singletons++data STuple2 :: (a, b) -> Type where+ STuple2 :: Sing x -> Sing y -> STuple2 '(x, y)++type instance Sing @(a, b) = STuple2++instance (SingKind a, SingKind b) => SingKind (a, b) where+ type Demote (a, b) = (Demote a, Demote b)+ fromSing (STuple2 sx sy) = (fromSing sx, fromSing sy)+ toSing (x, y) = case (toSing x, toSing y) of+ (SomeSing sx, SomeSing sy) -> SomeSing (STuple2 sx sy)++instance (SingI a, SingI b) => SingI '(a, b) where+ sing = STuple2 sing sing
+ src/PgSchema/Utils/Internal.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+module PgSchema.Utils.Internal where++import Data.Kind+import Data.List as L+import Data.Singletons+import Data.String+import Data.Text as T+import Prelude as P++#ifdef DEBUG+import Debug.Trace+#endif+++fromText :: IsString t => Text -> t+fromText = fromString . T.unpack+{-# INLINE fromText #-}++show' :: (IsString b, Show a) => a -> b+show' = fromString . P.show+{-# INLINE show' #-}++intercalate' :: Monoid a => a -> [a] -> a+intercalate' a = mconcat . L.intersperse a+{-# INLINE intercalate' #-}++unlines' :: (Monoid a, IsString a) => [a] -> a+unlines' = intercalate' "\n"+{-# INLINE unlines' #-}++type ToStar a = (SingKind (KindOf a), SingI a)++trace' :: String -> a -> a+traceShow' :: Show a => a -> b -> b+#ifdef DEBUG+trace' = trace . (<> "\n============") . ("=== Debug ===\n" <>)+traceShow' a = trace $ "=== Debug ===\n" <> P.show a <> "\n============"+#else+trace' _ = id+traceShow' _ = id+#endif+{-# INLINE trace' #-}+{-# INLINE traceShow' #-}++type family IsMaybe (x :: Type) :: Bool where+ IsMaybe (Maybe a) = 'True+ IsMaybe a = 'False++type family UnMaybe (x :: Type) :: Type where+ UnMaybe (Maybe a) = a+ UnMaybe a = a
+ src/PgSchema/Utils/ShowType.hs view
@@ -0,0 +1,69 @@+module PgSchema.Utils.ShowType where++import Data.List as L+import Data.String+import Data.Text as T+import PgSchema.Schema+import Prelude as P+++class ShowType a where+ showType :: a -> Text++instance ShowType Text where+ showType = fromString . P.show++instance ShowType a => ShowType (Maybe a) where+ showType Nothing = "'Nothing"+ showType (Just a) = "('Just " <> showType a <> ")"++instance ShowType Bool where+ showType True = "'True"+ showType False = "'False"++instance ShowType a => ShowType [a] where+ showType = (\x -> "'[ " <> x <> " ]") . T.intercalate "," . L.map showType++instance (ShowType a, ShowType b) => ShowType (a,b) where+ showType (a,b) = "'( " <> showType a <> "," <> showType b <> " )"++instance ShowType NameNS where+ showType NameNS{..} =+ "( " <> showType nnsNamespace <> " ->> " <> showType nnsName <> " )"++instance ShowType TypDef where+ showType TypDef{..} = "'TypDef " <> T.intercalate " "+ [showType typCategory, showType typElem, showType typEnum]++instance ShowType FldDef where+ showType FldDef{..} = "'FldDef " <> T.intercalate " "+ [showType fdType, showType fdNullable, showType fdHasDefault]++instance ShowType TabDef where+ showType TabDef{..} = "'TabDef " <> T.intercalate " "+ [showType tdFlds, showType tdKey, showType tdUniq]++instance ShowType RelDef where+ showType RelDef{..} = "'RelDef " <> T.intercalate " "+ [showType rdFrom, showType rdTo, showType rdCols]++instance ShowType Ref where+ showType Ref{..} = "'Ref " <> T.intercalate " "+ [showType fromName, showType fromDef, showType toName, showType toDef]++instance ShowType (RecField NameNS) where+ showType = \case+ RFEmpty s -> "'RFEmpty " <> showType s+ RFPlain fd -> "'RFPlain " <> showType fd+ RFAggr fd fn b -> "'RFAggr " <> T.intercalate " " [showType fd, showType fn, showType b]+ RFToHere t rr -> "'RFToHere " <> showType t <> " " <> showType rr+ RFFromHere t rr -> "'RFFromHere " <> showType t <> " " <> showType rr+ RFSelfRef t rr -> "'RFSelfRef " <> showType t <> " " <> showType rr++instance ShowType AggrFun where+ showType = \case+ ACount -> "'ACount"+ AMin -> "'AMin"+ AMax -> "'AMax"+ ASum -> "'ASum"+ AAvg -> "'AAvg"
+ src/PgSchema/Utils/TF.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module PgSchema.Utils.TF where++import Data.Singletons+import GHC.TypeLits+++-- | Second component of a type-level pair (replaces "Prelude.Singletons" @Snd@).+type family Fst (xs :: (a,b)) :: a where+ Fst '(x,_) = x++type family Snd (xs :: (a, b)) :: b where+ Snd '(_, y) = y++type family NatToSymbol (n :: Nat) :: Symbol where+ NatToSymbol 0 = "0"+ NatToSymbol 1 = "1"+ NatToSymbol 2 = "2"+ NatToSymbol 3 = "3"+ NatToSymbol 4 = "4"+ NatToSymbol 5 = "5"+ NatToSymbol 6 = "6"+ NatToSymbol 7 = "7"+ NatToSymbol 8 = "8"+ NatToSymbol 9 = "9"+ NatToSymbol n = AppendSymbol (NatToSymbol (Div n 10)) (NatToSymbol (Mod n 10))++-- >>> :kind! NatToSymbol 123+-- NatToSymbol 123 :: Symbol+-- = "123"++type family (++) (xs :: [a]) (ys :: [a]) :: [a] where+ (++) '[] ys = ys+ (++) (x ': xs) ys = x ': (xs ++ ys)++-- | @'True@ iff the list is empty (cf. @Null@ on lists in @singletons-base@).+type family Null (xs :: [a]) :: Bool where+ Null '[] = 'True+ Null (x ': xs) = 'False++type family Length (xs :: [a]) :: Nat where+ Length '[] = 0+ Length (x ': xs) = 1 + Length xs++type family SplitAt (n :: Nat) (xs :: [k]) :: ([k], [k]) where+ SplitAt 0 xs = '( '[], xs)+ SplitAt n '[] = '( '[], '[])+ -- Используем вспомогательный тип, чтобы "пробросить" результат рекурсии+ SplitAt n (x ': xs) = SplitAtHelper x (SplitAt (n - 1) xs)++-- Вспомогательный тип для конструирования результата+type family SplitAtHelper (x :: k) (res :: ([k], [k])) :: ([k], [k]) where+ SplitAtHelper x '(left, right) = '(x ': left, right)++-- >>> :kind! SplitAt 2 '[1,2,3,4,5]+-- SplitAt 2 '[1,2,3,4,5] :: ([Natural], [Natural])+-- = '( '[1, 2], '[3, 4, 5])++type family Map1 (f :: a ~> b) (xs :: [a]) :: [b] where+ Map1 f '[] = '[]+ Map1 f (x ': xs) = Apply f x ': Map1 f xs
+ test-gen/Main.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultilineStrings #-}+{-# LANGUAGE ImportQualifiedPost #-}++import Control.Exception (bracket)+import Data.Functor+import Data.ByteString.Char8 qualified as BS+import Database.PostgreSQL.Simple+import System.Environment+import PgSchema.Generation+import Prelude as P+++main :: IO ()+main = do+ connStr <- maybe "dbname=schema_test" BS.pack <$> lookupEnv "PG_CONN"+ bracket (connectPostgreSQL connStr) close $ \conn -> do+ putStrLn "Setting up schema..."+ execute_ conn """+ CREATE EXTENSION IF NOT EXISTS citext SCHEMA public VERSION \"1.6\";+ CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\" SCHEMA public VERSION \"1.1\";+ DROP SCHEMA IF EXISTS test_pgs CASCADE; + CREATE SCHEMA test_pgs;+ SET search_path TO test_pgs, public;+ CREATE TABLE base_converts + (cboolean boolean, cint4 int4, cfloat8 float8, cdate date + , ctime time, ctimestamp timestamp, ctimestamptz timestamptz, ctext text);+ create type color as enum ('red', 'green', 'blue');+ create table ext_converts + (ccitext citext, cbytea bytea, cjsonb jsonb, cjson json, cuuid uuid, ccolor color);+ create table base_arr_converts (cboolean boolean[], cint4 int4[]+ , cfloat8 float8[]+ , ctimestamptz timestamptz[] + , ctext text[]+ );+ create table ext_arr_converts + (ccitext citext[], cbytea bytea[], cjsonb jsonb[], cuuid uuid[], ccolor color[]);++ create table dim (+ id serial primary key,+ name text not null+ );++ -- Root of hierarchy; two FKs to dim for distinct roles (dim_a, dim_b).+ create table root (+ id serial primary key,+ code text not null,+ grp integer not null,+ name text not null,+ created_at timestamptz not null default now(),+ dim_a_id integer,+ dim_b_id integer,+ constraint root_code_grp_uq unique (code, grp),+ constraint root_dim_a_fk foreign key (dim_a_id) references dim (id) on delete restrict,+ constraint root_dim_b_fk foreign key (dim_b_id) references dim (id) on delete restrict+ );++ -- Simple child (single-column PK/FK).+ create table mid1 (+ id serial primary key,+ root_id integer not null,+ pos integer not null,+ flag boolean not null,+ sort_key integer not null,+ payload text,+ constraint mid1_root_fk foreign key (root_id) references root (id) on delete cascade+ );++ -- Child with composite PK and single-column FK to root.+ create table mid2 (+ root_id integer not null,+ seq integer not null,+ kind text not null,+ flag boolean not null,+ priority integer not null,+ payload jsonb,+ constraint mid2_pk primary key (root_id, seq),+ constraint mid2_root_fk foreign key (root_id) references root (id) on delete cascade+ );++ -- Leaf with composite PK and composite FK to mid2.+ create table leaf (+ root_id integer not null,+ seq integer not null,+ leaf_no integer not null,+ value float4 not null,+ category text,+ created_at timestamptz not null default now(),+ constraint leaf_pk primary key (root_id, seq, leaf_no),+ constraint leaf_mid2_fk foreign key (root_id, seq) references mid2 (root_id, seq) on delete cascade+ );++ -- Table for array types (nullable elements, no 2D arrays).+ create table arrays (+ id serial primary key,+ root_id integer,+ dates_nullable date[],+ jsons jsonb[],+ constraint arrays_root_fk foreign key (root_id) references root (id) on delete cascade+ );+ """++ putStrLn "Running generator..."+ void $ updateSchemaFile False "pg-schema/test-pgs/Sch.hs" (Right connStr)+ "Sch" -- ^ haskell module name to generate+ "Sch" -- ^ name of generated haskell type for schema+ (GenNames ["test_pgs"] [] []) -- ^ name of schemas in database
+ test-pgs/Main.hs view
@@ -0,0 +1,52 @@+module Main where++import Data.ByteString.Char8 qualified as BS+import Data.Pool as Pool+import Database.PostgreSQL.Simple+import Hedgehog+import System.Environment+import Test.Tasty+import Test.Tasty.Hedgehog++import Tests.BaseConverts+import Tests.Hierarchy+import Tests.Conditions++prop_not_implemented :: Property+prop_not_implemented = property $ fail "not implemented"++main :: IO ()+main = do+ connStr <- maybe "dbname=schema_test" BS.pack <$> lookupEnv "PG_CONN"+ pool <- newPool $ defaultPoolConfig (connectPostgreSQL connStr) close 10 10+ defaultMain $ testGroup "DB Tests"+ [ testGroup "Base converts (test_schema)"+ [ testProperty "Base types" $ prop_base_converts pool+ , testProperty "Array of base types" $ prop_base_arr_converts pool+ , testProperty "Extra types (bytea, jsonb, enums, uuid)" $ prop_ext_converts pool+ , testProperty "Array of extra types" $ prop_ext_arr_converts pool+ ]+ , testGroup "Hierarchy (test_dml)"+ [ testProperty "Insert/Upsert/Select root with children (simple FK)" $ prop_hier_insert_simple_fk pool+ , testProperty "Insert/Upsert/Select root with children (composite FK)" $ prop_hier_insert_composite_fk pool+ , testProperty "Select child with parent (RFFromHere)" $ prop_hier_select_child_with_parent pool+ , testProperty "Duplicate field names in root and nested structure" $ prop_hier_duplicate_names_root_nested pool+ ]+ , testGroup "Query (test_dml)"+ [ testProperty "'Simple' queries" $ prop_cond_query pool+ , testProperty "Conditions by duplicated path" $ prop_cond_by_dup_path pool+ ]+ -- , testProperty "Cond: Child / Parent exists" prop_not_implemented+ -- , testProperty "Conditions by path (root vs nested path)" prop_not_implemented+ -- ]+ -- , testGroup "Distinct / Order / Group by path (test_dml)"+ -- [ testProperty "Distinct on root fields" prop_not_implemented+ -- , testProperty "Distinct on parent path fields (join order vs qPath order)" prop_not_implemented+ -- , testProperty "Order by root; order by path" prop_not_implemented+ -- , testProperty "Group by path fields" prop_not_implemented+ -- ]+ -- , testGroup "Aggregates and duplicate names (test_dml)"+ -- [ testProperty "Multiple aggregate fields (max, min) in one select" prop_not_implemented+ -- , testProperty "Duplicate names: several group/agg fields in nested structure" prop_not_implemented+ -- ]+ ]
+ test-pgs/Sch.hs view
@@ -0,0 +1,483 @@+{- HLINT ignore -}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -freduction-depth=300 #-}+module Sch where++-- This file is generated and can't be edited.++import Control.DeepSeq+import Data.Hashable+import GHC.Generics+import GHC.TypeError qualified as TE+import GHC.TypeLits qualified as TL+import PgSchema.Import+data Sch++instance CTypDef Sch ( "pg_catalog" ->> "_bool" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_bool" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "bool" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_bytea" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_bytea" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "bytea" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_date" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_date" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "date" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_float8" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_float8" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "float8" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_int4" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_int4" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "int4" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_jsonb" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_jsonb" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "jsonb" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_text" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_text" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "text" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_timestamptz" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_timestamptz" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "timestamptz" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "_uuid" ) where+ type TTypDef Sch ( "pg_catalog" ->> "_uuid" ) = + 'TypDef "A" ('Just ( "pg_catalog" ->> "uuid" )) '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "bool" ) where+ type TTypDef Sch ( "pg_catalog" ->> "bool" ) = + 'TypDef "B" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "bytea" ) where+ type TTypDef Sch ( "pg_catalog" ->> "bytea" ) = + 'TypDef "U" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "date" ) where+ type TTypDef Sch ( "pg_catalog" ->> "date" ) = + 'TypDef "D" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "float4" ) where+ type TTypDef Sch ( "pg_catalog" ->> "float4" ) = + 'TypDef "N" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "float8" ) where+ type TTypDef Sch ( "pg_catalog" ->> "float8" ) = + 'TypDef "N" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "int4" ) where+ type TTypDef Sch ( "pg_catalog" ->> "int4" ) = + 'TypDef "N" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "int8" ) where+ type TTypDef Sch ( "pg_catalog" ->> "int8" ) = + 'TypDef "N" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "json" ) where+ type TTypDef Sch ( "pg_catalog" ->> "json" ) = + 'TypDef "U" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "jsonb" ) where+ type TTypDef Sch ( "pg_catalog" ->> "jsonb" ) = + 'TypDef "U" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "text" ) where+ type TTypDef Sch ( "pg_catalog" ->> "text" ) = + 'TypDef "S" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "time" ) where+ type TTypDef Sch ( "pg_catalog" ->> "time" ) = + 'TypDef "D" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "timestamp" ) where+ type TTypDef Sch ( "pg_catalog" ->> "timestamp" ) = + 'TypDef "D" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "timestamptz" ) where+ type TTypDef Sch ( "pg_catalog" ->> "timestamptz" ) = + 'TypDef "D" 'Nothing '[ ]++instance CTypDef Sch ( "pg_catalog" ->> "uuid" ) where+ type TTypDef Sch ( "pg_catalog" ->> "uuid" ) = + 'TypDef "U" 'Nothing '[ ]++instance CTypDef Sch ( "public" ->> "_citext" ) where+ type TTypDef Sch ( "public" ->> "_citext" ) = + 'TypDef "A" ('Just ( "public" ->> "citext" )) '[ ]++instance CTypDef Sch ( "public" ->> "citext" ) where+ type TTypDef Sch ( "public" ->> "citext" ) = + 'TypDef "S" 'Nothing '[ ]++instance CTypDef Sch ( "test_pgs" ->> "_color" ) where+ type TTypDef Sch ( "test_pgs" ->> "_color" ) = + 'TypDef "A" ('Just ( "test_pgs" ->> "color" )) '[ ]++instance CTypDef Sch ( "test_pgs" ->> "color" ) where+ type TTypDef Sch ( "test_pgs" ->> "color" ) = + 'TypDef "E" 'Nothing '[ "red","green","blue" ]++data instance PGEnum Sch ( "test_pgs" ->> "color" )+ = Color_red | Color_green | Color_blue+ deriving (Show, Read, Ord, Eq, Generic, Bounded, Enum)++instance Hashable (PGEnum Sch ( "test_pgs" ->> "color" ))++instance NFData (PGEnum Sch ( "test_pgs" ->> "color" ))++instance CTabDef Sch ( "test_pgs" ->> "arrays" ) where+ type TTabDef Sch ( "test_pgs" ->> "arrays" ) = + 'TabDef '[ "id","root_id","dates_nullable","jsons" ] '[ "id" ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "base_arr_converts" ) where+ type TTabDef Sch ( "test_pgs" ->> "base_arr_converts" ) = + 'TabDef '[ "cboolean"+ ,"cint4","cfloat8","ctimestamptz","ctext" ] '[ ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "base_converts" ) where+ type TTabDef Sch ( "test_pgs" ->> "base_converts" ) = + 'TabDef '[ "cboolean","cint4"+ ,"cfloat8","cdate","ctime","ctimestamp","ctimestamptz","ctext" ] '[ ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "dim" ) where+ type TTabDef Sch ( "test_pgs" ->> "dim" ) = + 'TabDef '[ "id","name" ] '[ "id" ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "ext_arr_converts" ) where+ type TTabDef Sch ( "test_pgs" ->> "ext_arr_converts" ) = + 'TabDef '[ "ccitext","cbytea","cjsonb","cuuid","ccolor" ] '[ ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "ext_converts" ) where+ type TTabDef Sch ( "test_pgs" ->> "ext_converts" ) = + 'TabDef '[ "ccitext"+ ,"cbytea","cjsonb","cjson","cuuid","ccolor" ] '[ ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "leaf" ) where+ type TTabDef Sch ( "test_pgs" ->> "leaf" ) = + 'TabDef '[ "root_id","seq","leaf_no"+ ,"value","category","created_at" ] '[ "root_id","seq","leaf_no" ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "mid1" ) where+ type TTabDef Sch ( "test_pgs" ->> "mid1" ) = + 'TabDef '[ "id"+ ,"root_id","pos","flag","sort_key","payload" ] '[ "id" ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "mid2" ) where+ type TTabDef Sch ( "test_pgs" ->> "mid2" ) = + 'TabDef '[ "root_id"+ ,"seq","kind","flag","priority","payload" ] '[ "root_id","seq" ] '[ ]++instance CTabDef Sch ( "test_pgs" ->> "root" ) where+ type TTabDef Sch ( "test_pgs" ->> "root" ) = + 'TabDef '[ "id","code","grp","name"+ ,"created_at","dim_a_id","dim_b_id" ] '[ "id" ] '[ '[ "code","grp" ] ]++instance CRelDef Sch ( "test_pgs" ->> "arrays_root_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "arrays_root_fk" ) = 'RelDef ( "test_pgs" ->> "arrays" ) ( "test_pgs" ->> "root" ) '[ '( "root_id","id" ) ]++instance CRelDef Sch ( "test_pgs" ->> "leaf_mid2_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "leaf_mid2_fk" ) = 'RelDef ( "test_pgs" ->> "leaf" ) ( "test_pgs" ->> "mid2" ) '[ '( "root_id","root_id" ),'( "seq","seq" ) ]++instance CRelDef Sch ( "test_pgs" ->> "mid1_root_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "mid1_root_fk" ) = 'RelDef ( "test_pgs" ->> "mid1" ) ( "test_pgs" ->> "root" ) '[ '( "root_id","id" ) ]++instance CRelDef Sch ( "test_pgs" ->> "mid2_root_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "mid2_root_fk" ) = 'RelDef ( "test_pgs" ->> "mid2" ) ( "test_pgs" ->> "root" ) '[ '( "root_id","id" ) ]++instance CRelDef Sch ( "test_pgs" ->> "root_dim_a_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "root_dim_a_fk" ) = 'RelDef ( "test_pgs" ->> "root" ) ( "test_pgs" ->> "dim" ) '[ '( "dim_a_id","id" ) ]++instance CRelDef Sch ( "test_pgs" ->> "root_dim_b_fk" ) where+ type TRelDef Sch ( "test_pgs" ->> "root_dim_b_fk" ) = 'RelDef ( "test_pgs" ->> "root" ) ( "test_pgs" ->> "dim" ) '[ '( "dim_b_id","id" ) ]++instance CTabRels Sch ( "test_pgs" ->> "arrays" ) where+ type TFrom Sch ( "test_pgs" ->> "arrays" ) = + '[ ( "test_pgs" ->> "arrays_root_fk" ) ]++ type TTo Sch ( "test_pgs" ->> "arrays" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "base_arr_converts" ) where+ type TFrom Sch ( "test_pgs" ->> "base_arr_converts" ) = + '[ ]++ type TTo Sch ( "test_pgs" ->> "base_arr_converts" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "base_converts" ) where+ type TFrom Sch ( "test_pgs" ->> "base_converts" ) = + '[ ]++ type TTo Sch ( "test_pgs" ->> "base_converts" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "dim" ) where+ type TFrom Sch ( "test_pgs" ->> "dim" ) = + '[ ]++ type TTo Sch ( "test_pgs" ->> "dim" ) = + '[ ( "test_pgs" ->> "root_dim_a_fk" )+ ,( "test_pgs" ->> "root_dim_b_fk" ) ]++instance CTabRels Sch ( "test_pgs" ->> "ext_arr_converts" ) where+ type TFrom Sch ( "test_pgs" ->> "ext_arr_converts" ) = + '[ ]++ type TTo Sch ( "test_pgs" ->> "ext_arr_converts" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "ext_converts" ) where+ type TFrom Sch ( "test_pgs" ->> "ext_converts" ) = + '[ ]++ type TTo Sch ( "test_pgs" ->> "ext_converts" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "leaf" ) where+ type TFrom Sch ( "test_pgs" ->> "leaf" ) = + '[ ( "test_pgs" ->> "leaf_mid2_fk" ) ]++ type TTo Sch ( "test_pgs" ->> "leaf" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "mid1" ) where+ type TFrom Sch ( "test_pgs" ->> "mid1" ) = + '[ ( "test_pgs" ->> "mid1_root_fk" ) ]++ type TTo Sch ( "test_pgs" ->> "mid1" ) = + '[ ]++instance CTabRels Sch ( "test_pgs" ->> "mid2" ) where+ type TFrom Sch ( "test_pgs" ->> "mid2" ) = + '[ ( "test_pgs" ->> "mid2_root_fk" ) ]++ type TTo Sch ( "test_pgs" ->> "mid2" ) = + '[ ( "test_pgs" ->> "leaf_mid2_fk" ) ]++instance CTabRels Sch ( "test_pgs" ->> "root" ) where+ type TFrom Sch ( "test_pgs" ->> "root" ) = + '[ ( "test_pgs" ->> "root_dim_a_fk" )+ ,( "test_pgs" ->> "root_dim_b_fk" ) ]++ type TTo Sch ( "test_pgs" ->> "root" ) = + '[ ( "test_pgs" ->> "arrays_root_fk" )+ ,( "test_pgs" ->> "mid1_root_fk" ),( "test_pgs" ->> "mid2_root_fk" ) ]++type family TDBFieldInfoSch (t :: NameNSK) (f :: TL.Symbol) :: RecFieldK NameNSK where+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) "dates_nullable" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_date" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) "id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) "jsons" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_jsonb" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) "root_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) "arrays_root_fk" = 'RFFromHere ( "test_pgs" ->> "root" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "arrays" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "arrays" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: id, root_id, dates_nullable, jsons."+ TE.:$$: TE.Text " Foreign key constraints: arrays_root_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) "cboolean" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_bool" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) "cfloat8" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_float8" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) "cint4" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_int4" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) "ctext" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_text" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) "ctimestamptz" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_timestamptz" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_arr_converts" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "base_arr_converts" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: cboolean, cint4, cfloat8, ctimestamptz, ctext."+ TE.:$$: TE.Text " Foreign key constraints: ."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "cboolean" = 'RFPlain ('FldDef ( "pg_catalog" ->> "bool" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "cdate" = 'RFPlain ('FldDef ( "pg_catalog" ->> "date" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "cfloat8" = 'RFPlain ('FldDef ( "pg_catalog" ->> "float8" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "cint4" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "ctext" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "ctime" = 'RFPlain ('FldDef ( "pg_catalog" ->> "time" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "ctimestamp" = 'RFPlain ('FldDef ( "pg_catalog" ->> "timestamp" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) "ctimestamptz" = 'RFPlain ('FldDef ( "pg_catalog" ->> "timestamptz" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "base_converts" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "base_converts" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: cboolean, cint4, cfloat8, cdate, ctime, ctimestamp, ctimestamptz, ctext."+ TE.:$$: TE.Text " Foreign key constraints: ."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "dim" ) "id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "dim" ) "name" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "dim" ) "root_dim_a_fk" = 'RFToHere ( "test_pgs" ->> "root" )+ '[ 'Ref "dim_a_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "dim" ) "root_dim_b_fk" = 'RFToHere ( "test_pgs" ->> "root" )+ '[ 'Ref "dim_b_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "dim" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "dim" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: id, name."+ TE.:$$: TE.Text " Foreign key constraints: root_dim_a_fk, root_dim_b_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) "cbytea" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_bytea" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) "ccitext" = 'RFPlain ('FldDef ( "public" ->> "_citext" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) "ccolor" = 'RFPlain ('FldDef ( "test_pgs" ->> "_color" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) "cjsonb" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_jsonb" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) "cuuid" = 'RFPlain ('FldDef ( "pg_catalog" ->> "_uuid" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_arr_converts" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "ext_arr_converts" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: ccitext, cbytea, cjsonb, cuuid, ccolor."+ TE.:$$: TE.Text " Foreign key constraints: ."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "cbytea" = 'RFPlain ('FldDef ( "pg_catalog" ->> "bytea" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "ccitext" = 'RFPlain ('FldDef ( "public" ->> "citext" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "ccolor" = 'RFPlain ('FldDef ( "test_pgs" ->> "color" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "cjson" = 'RFPlain ('FldDef ( "pg_catalog" ->> "json" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "cjsonb" = 'RFPlain ('FldDef ( "pg_catalog" ->> "jsonb" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) "cuuid" = 'RFPlain ('FldDef ( "pg_catalog" ->> "uuid" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "ext_converts" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "ext_converts" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: ccitext, cbytea, cjsonb, cjson, cuuid, ccolor."+ TE.:$$: TE.Text " Foreign key constraints: ."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "category" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "created_at" = 'RFPlain ('FldDef ( "pg_catalog" ->> "timestamptz" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "leaf_no" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "root_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "seq" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "value" = 'RFPlain ('FldDef ( "pg_catalog" ->> "float4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) "leaf_mid2_fk" = 'RFFromHere ( "test_pgs" ->> "mid2" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ , 'Ref "seq" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "seq" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) ]+ TDBFieldInfoSch ( "test_pgs" ->> "leaf" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "leaf" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: root_id, seq, leaf_no, value, category, created_at."+ TE.:$$: TE.Text " Foreign key constraints: leaf_mid2_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "flag" = 'RFPlain ('FldDef ( "pg_catalog" ->> "bool" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "payload" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "pos" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "root_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "sort_key" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) "mid1_root_fk" = 'RFFromHere ( "test_pgs" ->> "root" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "mid1" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "mid1" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: id, root_id, pos, flag, sort_key, payload."+ TE.:$$: TE.Text " Foreign key constraints: mid1_root_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "flag" = 'RFPlain ('FldDef ( "pg_catalog" ->> "bool" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "kind" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "payload" = 'RFPlain ('FldDef ( "pg_catalog" ->> "jsonb" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "priority" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "root_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "seq" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "leaf_mid2_fk" = 'RFToHere ( "test_pgs" ->> "leaf" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ , 'Ref "seq" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "seq" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) ]+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) "mid2_root_fk" = 'RFFromHere ( "test_pgs" ->> "root" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "mid2" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "mid2" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: root_id, seq, kind, flag, priority, payload."+ TE.:$$: TE.Text " Foreign key constraints: mid2_root_fk, leaf_mid2_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "code" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "created_at" = 'RFPlain ('FldDef ( "pg_catalog" ->> "timestamptz" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "dim_a_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "dim_b_id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "grp" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "id" = 'RFPlain ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "name" = 'RFPlain ('FldDef ( "pg_catalog" ->> "text" ) 'False 'False)+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "arrays_root_fk" = 'RFToHere ( "test_pgs" ->> "arrays" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "mid1_root_fk" = 'RFToHere ( "test_pgs" ->> "mid1" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "mid2_root_fk" = 'RFToHere ( "test_pgs" ->> "mid2" )+ '[ 'Ref "root_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "root_dim_a_fk" = 'RFFromHere ( "test_pgs" ->> "dim" )+ '[ 'Ref "dim_a_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) "root_dim_b_fk" = 'RFFromHere ( "test_pgs" ->> "dim" )+ '[ 'Ref "dim_b_id" ('FldDef ( "pg_catalog" ->> "int4" ) 'True 'False) "id" ('FldDef ( "pg_catalog" ->> "int4" ) 'False 'True) ]+ TDBFieldInfoSch ( "test_pgs" ->> "root" ) f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch+ TE.:$$: TE.Text "for table " TE.:<>: TE.ShowType ( "test_pgs" ->> "root" )+ TE.:$$: TE.Text "name " TE.:<>: TE.ShowType f TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Valid values are:"+ TE.:$$: TE.Text " Fields: id, code, grp, name, created_at, dim_a_id, dim_b_id."+ TE.:$$: TE.Text " Foreign key constraints: root_dim_a_fk, root_dim_b_fk, arrays_root_fk, mid1_root_fk, mid2_root_fk."+ TE.:$$: TE.Text ""+ TE.:$$: TE.Text "Your source or target type or renaimer is probably invalid."+ TE.:$$: TE.Text "")+ TDBFieldInfoSch t f = TE.TypeError (TE.Text "In schema " TE.:<>: TE.ShowType Sch TE.:<>: TE.Text " the table " TE.:<>: TE.ShowType t TE.:<>: TE.Text " is not defined."+ TE.:$$: TE.Text "")++instance (ToStar (TDBFieldInfo Sch t f), ToStar t, ToStar f) => CDBFieldInfo Sch t f where+ type TDBFieldInfo Sch t f = TDBFieldInfoSch t f++instance CSchema Sch where+ type TTabs Sch = '[ ( "test_pgs" ->> "arrays" ),( "test_pgs" ->> "base_arr_converts" )+ ,( "test_pgs" ->> "base_converts" ),( "test_pgs" ->> "dim" )+ ,( "test_pgs" ->> "ext_arr_converts" ),( "test_pgs" ->> "ext_converts" )+ ,( "test_pgs" ->> "leaf" ),( "test_pgs" ->> "mid1" )+ ,( "test_pgs" ->> "mid2" ),( "test_pgs" ->> "root" ) ]++ type TTypes Sch = '[ ( "pg_catalog" ->> "_bool" )+ ,( "pg_catalog" ->> "_bytea" ),( "pg_catalog" ->> "_date" )+ ,( "pg_catalog" ->> "_float8" ),( "pg_catalog" ->> "_int4" )+ ,( "pg_catalog" ->> "_jsonb" ),( "pg_catalog" ->> "_text" )+ ,( "pg_catalog" ->> "_timestamptz" ),( "pg_catalog" ->> "_uuid" )+ ,( "pg_catalog" ->> "bool" ),( "pg_catalog" ->> "bytea" )+ ,( "pg_catalog" ->> "date" ),( "pg_catalog" ->> "float4" )+ ,( "pg_catalog" ->> "float8" ),( "pg_catalog" ->> "int4" )+ ,( "pg_catalog" ->> "int8" ),( "pg_catalog" ->> "json" )+ ,( "pg_catalog" ->> "jsonb" ),( "pg_catalog" ->> "text" )+ ,( "pg_catalog" ->> "time" ),( "pg_catalog" ->> "timestamp" )+ ,( "pg_catalog" ->> "timestamptz" ),( "pg_catalog" ->> "uuid" )+ ,( "public" ->> "_citext" ),( "public" ->> "citext" )+ ,( "test_pgs" ->> "_color" ),( "test_pgs" ->> "color" ) ]+
+ test-pgs/Tests/Aggregates.hs view
@@ -0,0 +1,11 @@+module Tests.Aggregates where++import Data.Pool as Pool+import Database.PostgreSQL.Simple+import Hedgehog++prop_aggr_multiple_max_min :: Pool Connection -> Property+prop_aggr_multiple_max_min _pool = property success++prop_aggr_duplicate_names_nested :: Pool Connection -> Property+prop_aggr_duplicate_names_nested _pool = property success
+ test-pgs/Tests/BaseConverts.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE BlockArguments #-}+module Tests.BaseConverts where++import Control.Exception+import Data.Aeson as A (Value(..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.CaseInsensitive+import Data.Functor+import Data.Int+import Data.List qualified as L+import Data.Pool as Pool+import Data.Scientific+import Data.String as S+import Data.Text as T+import Data.Time+import Data.UUID.Types+import qualified Data.Vector as Vec+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.Types (PGArray(..))+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude as P+import PgSchema.DML+import Sch+import Utils+++type BaseConverts = "cboolean" := Maybe Bool+ :. "cint4" := Maybe Int32+ :. "cdate" := Maybe Day+ :. "ctime" := Maybe TimeOfDay+ :. "ctimestamp" := Maybe LocalTime+ :. "ctimestamptz" := Maybe UTCTime+ :. "ctext" := Maybe Text+ :. "cfloat8" := Maybe Double++type BaseArrConverts = "cboolean" := Maybe (PgArr Bool)+ :. "cint4" := Maybe (PgArr Int32)+ :. "cfloat8" := Maybe (PgArr Double)+ :. "ctext" := Maybe (PgArr Text)+ :. "ctimestamptz" := Maybe (PgArr UTCTime)++type ExtConverts = "ccitext" := Maybe (CI Text)+ :. "ccolor" := Maybe (EnumPGS "color" )+ :. "cbytea" := Maybe (Binary BS.ByteString)+ :. "cjsonb" := Maybe Value+ :. "cjson" := Maybe Value+ :. "cuuid" := Maybe UUID++type ExtArrConverts = "ccitext" := Maybe (PgArr (CI Text))+ :. "ccolor" := Maybe (PgArr (EnumPGS "color" ))+ :. "cbytea" := Maybe (PgArr (Binary BS.ByteString))+ :. "cjsonb" := Maybe (PgArr Value)+ :. "cuuid" := Maybe (PgArr UUID)++prop_base_converts :: Pool Connection -> Property+prop_base_converts pool = withTests 30 $ property do+ recs <- forAll (genData BaseConverts)+ (resSel, resIns, resUpd) <- evalIO $ withPool pool \conn -> do+ void $ insSch_ "base_converts" conn recs+ (res, _) <- selSch "base_converts" conn qpEmpty+ res'' <- updByCond "base_converts" conn+ ("cint4" =: Just (10 :: Int32)) ("cboolean" =? Just False)+ (res', _) <- insSch "base_converts" conn recs+ pure (res, res', res'')+ L.sort resSel === L.sort recs+ resIns === recs+ L.sort resUpd === L.sort ((\(a:.b:.c) -> a:. "cint4" =: Just (10::Int32) :.c)+ <$> L.filter (\(PgTag a:._) -> a == Just False) recs)++prop_base_arr_converts :: Pool Connection -> Property+prop_base_arr_converts pool = withTests 30 $ property do+ recs <- forAll (genData BaseArrConverts)+ ds <- forAll $ Gen.list (Range.linear 0 20) genUTCTime+ (resSel, resIns, resUpd::[BaseArrConverts]) <- evalIO $ withPool pool \conn -> do+ void $ insSch_ "base_arr_converts" conn recs+ (res, _) <- selSch "base_arr_converts" conn qpEmpty+ res'' <- updByCond "base_arr_converts" conn+ ("ctimestamptz" =: Just (pgArr' ds)) mempty+ (res', _) <- insSch "base_arr_converts" conn recs+ pure (res, res', res'')+ L.sort resSel === L.sort recs+ resIns === recs+ L.length resUpd === L.length recs++prop_ext_converts :: Pool Connection -> Property+prop_ext_converts pool = withTests 30 $ property do+ recs <- forAll (genData ExtConverts)+ (resSel, resIns, resUpd) <- evalIO $ withPool pool \conn -> do+ void $ insSch_ "ext_converts" conn recs+ (res, _) <- selSch "ext_converts" conn qpEmpty+ res'' <- updByCond "ext_converts" conn+ ("ccitext" =: Just ("CaSes" :: CI Text)) ("ccolor" =? Just Color_red)+ (res', _) <- insSch "ext_converts" conn recs+ pure (res, res', res'')+ L.sort resSel === L.sort recs+ resIns === recs+ L.sort resUpd === L.sort ((\(a:.b) -> "ccitext" =: Just ("cAses" :: CI Text) :.b)+ <$> L.filter (\(_ :. PgTag a :. _) -> a == Just Color_red) recs)++prop_ext_arr_converts :: Pool Connection -> Property+prop_ext_arr_converts pool = withTests 30 $ property do+ recs <- forAll (genData ExtArrConverts)+ evalIO $ withPool pool \conn -> do+ void $ insSch_ "ext_arr_converts" conn recs
+ test-pgs/Tests/Conditions.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}++module Tests.Conditions where++import Control.Monad.IO.Class+import Data.Functor+import Data.Function+import Data.List qualified as L+import Data.Ord+import Data.Pool as Pool+import Data.Text as T+import Database.PostgreSQL.Simple+import GHC.Generics+import GHC.Int+import GHC.Stack (HasCallStack)+import Hedgehog+import PgSchema.DML+import Utils+++data RootI = MkRootI+ { code :: Text+ , grp :: Int32+ , someEmpty :: ()+ , name :: Text }+ deriving (Show, Generic)+ deriving anyclass GenDefault++data Mid1I = MkMid1I+ { pos :: Int32+ , flag :: Bool+ , sort_key :: Int32+ , payload :: Maybe Text }+ deriving (Show, Generic)+ deriving anyclass GenDefault++data Mid2I = MkMid2I+ { seq :: Int32+ , kind :: Text+ , flag :: Bool+ , priority :: Int32 }+ deriving (Show, Generic, Eq, Ord)+ deriving anyclass GenDefault++data LeafI = MkLeafI+ { leaf_no :: Int32+ , value :: Double }+ deriving (Generic, Eq, Ord, Show)+ deriving anyclass GenDefault++eqRoot :: RootI -> RootI -> Bool+eqRoot r1 r2 = (r1.code, r1.grp) == (r2.code, r2.grp)++type InsData = "mid1_root_fk" := [Mid1I]+ :. "mid2_root_fk" := ["leaf_mid2_fk" := [LeafI] :. Mid2I]+ :. RootI++insData :: MonadIO m => Pool Connection -> PropertyT m [InsData]+insData pool = do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootI 1 200)+ mid1In <- forAll (genData' Mid1I 0 10)+ mid2In <- forAll (L.nubBy ((==) `on` (.seq)) <$> genData' Mid2I 0 10)+ leafIn <- forAll (L.nubBy ((==) `on` (.leaf_no)) <$> genData' LeafI 0 10)+ let+ inIns = rootsIn <&> \r -> "mid1_root_fk" =: mid1In+ :. "mid2_root_fk" =: (mid2In <&> \m2 -> "leaf_mid2_fk" =: leafIn :. m2)+ :. r+ evalIO $ withResource pool \conn -> do+ delByCond "leaf" conn mempty+ delByCond "mid1" conn mempty+ delByCond "mid2" conn mempty+ delByCond "root" conn mempty+ void $ insJSON_ "root" conn inIns+ pure inIns++prop_cond_query :: Pool Connection -> Property+prop_cond_query pool = withTests 30 $ property do+ inIns <- insData pool+ (res :: [InsData], _) <- evalIO $ withResource pool \conn ->+ selSch "root" conn $ qRoot do+ qWhere $ ("grp" >? (100::Int32) ||| pinArr "grp" ([0..70]::[Int32]))+ &&& pchild (TS "mid1_root_fk")+ defTabParam { order = [ascf "pos"], lo = LO (Just 2) Nothing }+ ("sort_key" <? (100::Int32))+ qPath "mid1_root_fk" do+ qDistinctOn [ascf "root_id"]+ qWhere $ pnull "payload"+ qPath "mid2_root_fk" do+ qPath "leaf_mid2_fk" do+ qWhere $ pparent (TS "leaf_mid2_fk")+ $ pparent (TS "mid2_root_fk") $ "grp" >? (0::Int32)+ qOrderBy [descf "kind"]+ L.length (L.filter (\(PgTag m1s :. _ :. r) ->+ (r.grp > 100 || r.grp `L.elem` [0..70])+ && L.any ((<100) . (.sort_key)) (L.take 2 $ L.sortBy (comparing (.pos)) m1s)+ )+ inIns) === L.length res++type OutData = "mid2_root_fk" := [Mid2I] :. InsData++-- We can have similar pathes in select.+-- Params are applied for all branches with this path+prop_cond_by_dup_path :: Pool Connection -> Property+prop_cond_by_dup_path pool = withTests 30 $ property do+ inIns <- insData pool+ (sel :: [OutData], _) <- evalIO $ withResource pool \conn ->+ selSch "root" conn $ qRoot+ $ qPath "mid2_root_fk" do+ qWhere $ "flag" =? True+ qPath "leaf_mid2_fk" do+ qWhere $ "leaf_no" >? (100::Int32)+ L.sort [m2 | (PgTag m2s :. _) <- sel, m2 <- m2s]+ === L.sort [m2 | (_ :. PgTag m2s :. _) <- inIns, (_ :. m2) <- m2s, m2.flag]+ L.sort [(m2, L.length ls) | (_ :. _ :. PgTag m2s :. _) <- sel, (PgTag ls :. m2) <- m2s]+ === L.sort [(m2, L.length $ L.filter ((>100) . (.leaf_no)) ls)+ | (_ :. PgTag m2s :. _) <- inIns, (PgTag ls :. m2) <- m2s, m2.flag]
+ test-pgs/Tests/Hierarchy.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}+module Tests.Hierarchy where++import Control.Monad (void)+import Data.Function (on)+import Data.Functor+import Data.Int (Int32, Int64)+import Data.List qualified as L+import Data.Maybe (fromMaybe)+import Data.Pool as Pool+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.Text.IO as T+import Data.Time (UTCTime, getCurrentTime)+import Database.PostgreSQL.Simple+import GHC.Generics+import Hedgehog+import PgSchema.DML+import Sch+import Utils+++type RootRec = "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := ()++type Mid1Rec =+ "flag" := Bool :. "pos" := Int32 :. "sortKey" := Int32 :. "payload" := Maybe Text++data Mid2Rec = MkMid2Rec+ { seq :: Int32+ , kind :: Text+ , flag :: Bool+ , priority :: Int32 }+ deriving (Generic, Eq, Ord, Show)+ deriving anyclass GenDefault++data Mid2RecRev = MkMid2RecRev+ { seq :: Int32+ , kind :: Text+ , mid2RootFk :: RootRec+ :. "mid1_root_fk" := ["flag" := Bool]+ :. "mid1_root_fk2" := ["pos" := Int32]}+ deriving (Generic, Eq, Ord, Show)+ deriving anyclass GenDefault++data LeafI = MkLeafI+ { leafNo :: Int32+ , someEmpty :: ()+ , value :: Double }+ deriving (Generic, Eq, Ord, Show)+ deriving anyclass GenDefault++data Leaf = MkLeaf+ { leafNo :: Int32+ , value :: Double+ , someEmpty :: ()+ , category :: Maybe Text+ , leafMid2Fk :: Mid2Rec+ , leaf_mid2_rev_fk :: Mid2RecRev }+ deriving (Generic, Eq, Ord, Show)+ deriving anyclass GenDefault+-- >>> getRecordInfo @('Ann RenamerSch Sch (TS "leaf")) @LeafI+-- RecordInfo {tabName = NameNS {nnsNamespace = "test_pgs", nnsName = "leaf"}, fields = [FieldInfo {fieldName = "leaf_no", fieldDbName = "leaf_no", fieldKind = RFPlain (FldDef {fdType = NameNS {nnsNamespace = "pg_catalog", nnsName = "int4"}, fdNullable = False, fdHasDefault = False})},FieldInfo {fieldName = "value", fieldDbName = "value", fieldKind = RFPlain (FldDef {fdType = NameNS {nnsNamespace = "pg_catalog", nnsName = "float4"}, fdNullable = False, fdHasDefault = False})}]}++eqRoot :: RootRec -> RootRec -> Bool+eqRoot (a1 :. b1 :. c1) (a2 :. b2 :. c2) = (a1, b1) == (a2, b2)++prop_hier_insert_simple_fk :: Pool Connection -> Property+prop_hier_insert_simple_fk pool = withTests 30 $ property do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 200)+ mid1In <- forAll (genData' Mid1Rec 0 20)+ let inIns = rootsIn <&> ("mid1RootFk" =: mid1In :.)+ (outIns, outSel1, outUps, outSel2) <- evalIO $ withPool pool \conn -> do+ delByCond "mid1" conn mempty+ delByCond "root" conn mempty+ (fst -> (outIns' :: ["id" := Int32 :. "mid1RootFk" := ["id" := Int32 :. Mid1Rec]])) <-+ insJSON "root" conn inIns+ (fst -> (outSel1' :: ["id" := Int32 :. "mid1RootFk" := [Mid1Rec] :. RootRec])) <-+ selSch "root" conn qpEmpty+ (outUps' :: ["id" := Int32 :. "mid1_root_fk" := [Mid1Rec] :. RootRec], _txt) <-+ upsJSON "root" conn $ outIns' <&> \(ir :. PgTag ms) -> "mid1_root_fk" =:+ (ms <&> \(i :. flag :. x) -> i :. (not <$> flag) :. x) :. ir+ -- T.putStrLn $ "\n\n" <> txt <> "\n\n"+ (fst -> (outSel2' :: ["id" := Int32 :. "mid1_root_fk" := [Mid1Rec] :. RootRec])) <-+ selSch "root" conn qpEmpty+ pure (outIns', outSel1', outUps', outSel2')+ L.sort (inIns <&> \(ms :. _) -> L.length ms) ===+ L.sort (outIns <&> \(_ :. ms) -> L.length ms)+ L.length outIns === L.length outSel1+ L.length outIns === L.length outSel2+ L.length outIns === L.length outUps+ (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)+ === (L.sort outSel2 <&> \(ir :. ms :. _) -> ir :. length ms)+ (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)+ === (L.sort outUps <&> \(ir :. ms :. _) -> ir :. length ms)+ (L.sort outIns <&> \(ir :. PgTag ms) -> ir :. length (filter (\(_ :. PgTag b :. _) -> b) ms))+ === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> not b) ms))+ (L.sort outUps <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> b) ms))+ === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (\(PgTag b :. _) -> b) ms))++prop_hier_insert_composite_fk :: Pool Connection -> Property+prop_hier_insert_composite_fk pool = withTests 30 $ property do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 200)+ mid2In <- forAll (L.nubBy ((==) `on` (.seq)) <$> genData' Mid2Rec 0 20)+ let inIns = rootsIn <&> (("mid2_root_fk" =: mid2In) :.)+ (outIns, outSel1, outUps, outSel2) <- evalIO $ withPool pool \conn -> do+ delByCond "mid2" conn mempty+ delByCond "root" conn mempty+ (fst -> (outIns' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec]])) <-+ insJSON "root" conn inIns+ (fst -> (outSel1' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec])) <-+ selSch "root" conn qpEmpty+ (outUps' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec], _txt) <-+ upsJSON "root" conn $ outIns' <&> \(ir :. PgTag ms) -> "mid2_root_fk" =:+ (ms <&> \m -> m { flag = not m.flag }) :. ir+ -- T.putStrLn $ "\n\n" <> txt <> "\n\n"+ (fst -> (outSel2' :: ["id" := Int32 :. "mid2_root_fk" := [Mid2Rec] :. RootRec])) <-+ selSch "root" conn qpEmpty+ pure (outIns', outSel1', outUps', outSel2')+ L.sort (inIns <&> \(ms :. _) -> L.length ms) ===+ L.sort (outIns <&> \(_ :. ms) -> L.length ms)+ L.length outIns === L.length outSel1+ L.length outIns === L.length outSel2+ L.length outIns === L.length outUps+ (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)+ === (L.sort outSel2 <&> \(ir :. ms :. _) -> ir :. length ms)+ (L.sort outIns <&> \(ir :. ms) -> ir :. length ms)+ === (L.sort outUps <&> \(ir :. ms :. _) -> ir :. length ms)+ (L.sort outIns <&> \(ir :. PgTag ms) -> ir :. length (filter (.flag) ms))+ === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (not . (.flag)) ms))+ (L.sort outUps <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (.flag) ms))+ === (L.sort outSel2 <&> \(ir :. PgTag ms :. _) -> ir :. length (filter (.flag) ms))++prop_hier_select_child_with_parent :: Pool Connection -> Property+prop_hier_select_child_with_parent pool = withTests 30 $ property do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 200)+ mid2In <- forAll (L.nubBy ((==) `on` (.seq)) <$> genData' Mid2Rec 0 20)+ (outIns, outSel) <- evalIO $ withPool pool \conn -> do+ delByCond "mid2" conn mempty+ delByCond "root" conn mempty+ (fst -> (outIns' :: ["mid2_root_fk" := [Mid2Rec] :. RootRec])) <-+ insJSON "root" conn $ rootsIn <&> (("mid2_root_fk" =: mid2In) :.)+ (fst -> (outSel' :: [Mid2Rec :. "mid2_root_fk" := RootRec])) <-+ selSch "mid2" conn qpEmpty+ pure (outIns', outSel')+ L.sort (outSel <&> \(m2r :. PgTag rr) -> m2r :. rr) ===+ L.sort (outIns >>= \(PgTag m2rs :. rr) -> m2rs <&> (:. rr))++prop_hier_duplicate_names_root_nested :: Pool Connection -> Property+prop_hier_duplicate_names_root_nested pool = withTests 30 $ property do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 100)+ mid2In <- forAll (L.nubBy ((==) `on` (.seq)) <$> genData' Mid2Rec 0 10)+ leafIn <- forAll (L.nubBy ((==) `on` (.leafNo)) <$> genData' LeafI 0 10)+ let inIns = rootsIn <&> (("mid2_root_fk" =: (mid2In <&> (("leaf_mid2_fk" =: leafIn) :.))) :.)+ outSel <- evalIO $ withPool pool \conn -> do+ delByCond "leaf" conn mempty+ delByCond "mid2" conn mempty+ delByCond "root" conn mempty+ void $ insJSON_ "root" conn inIns+ (fst -> (outSel' :: [Leaf])) <- selSch "leaf" conn qpEmpty+ pure outSel'+ L.length outSel === L.length (inIns >>= \(PgTag xs :. _) -> xs >>= \(PgTag ys :. _) -> ys )
+ test-pgs/Tests/Path.hs view
@@ -0,0 +1,17 @@+module Tests.Path where++import Data.Pool as Pool+import Database.PostgreSQL.Simple+import Hedgehog++prop_path_distinct_root :: Pool Connection -> Property+prop_path_distinct_root _pool = property success++prop_path_distinct_parent_path :: Pool Connection -> Property+prop_path_distinct_parent_path _pool = property success++prop_path_order :: Pool Connection -> Property+prop_path_order _pool = property success++prop_path_group_by :: Pool Connection -> Property+prop_path_group_by _pool = property success
+ test-pgs/Utils.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Utils where++import Control.Exception+import Data.Aeson as A (Value(..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.CaseInsensitive+import Data.Functor+import Data.Int+import Data.List qualified as L+import Data.Pool as Pool+import Data.Scientific+import Data.String as S+import Data.Text as T+import Data.Time+import Data.UUID.Types+import qualified Data.Vector as Vec+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.Types (PGArray(..))+import GHC.Generics+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Prelude as P+import PgSchema.DML+import Sch+import GHC.TypeLits (KnownSymbol)+++type TS tab = "test_pgs" ->> tab+++type EnumPGS s = PGEnum Sch ("test_pgs" ->> s)++data RenamerSch :: Renamer++type instance ApplyRenamer RenamerSch s = RenamerSchImpl s++type family RenamerSchImpl s where+ RenamerSchImpl "leaf_mid2_rev_fk" = "leaf_mid2_fk"+ RenamerSchImpl "mid1_root_fk2" = "mid1_root_fk"+ RenamerSchImpl s = CamelToSnake s++withRollback :: Connection -> IO a -> IO a+withRollback conn act = execute_ conn "BEGIN" >> act `finally` rollback conn++withPool :: Pool Connection -> (Connection -> IO a) -> IO a+withPool pool a = Pool.withResource pool \conn -> withRollback conn (a conn)++type AnnSch tn = 'Ann RenamerSch Sch 3 (TS tn)++insSch+ :: forall tn -> forall r r'. InsertReturning (AnnSch tn) r r'+ => Connection -> [r] -> IO ([r'], Text)+insSch tn = insertSch (AnnSch tn)++insSch_+ :: forall tn -> forall r. InsertNonReturning (AnnSch tn) r+ => Connection -> [r] -> IO (Int64, Text)+insSch_ tn = insertSch_ (AnnSch tn)++selSch :: forall tn -> forall r. Selectable (AnnSch tn) r+ => Connection -> QueryParam Sch (TS tn) -> IO ([r], (Text,[SomeToField]))+selSch tn = selectSch (AnnSch tn)++updByCond_+ :: forall tn -> forall r. UpdateNonReturning (AnnSch tn) r+ => Connection -> r -> Cond Sch (TS tn) -> IO Int64+updByCond_ tn = updateByCond_ (AnnSch tn)++updByCond :: forall tn -> forall r r'. UpdateReturning (AnnSch tn) r r'+ => Connection -> r -> Cond Sch (TS tn) -> IO [r']+updByCond tn = updateByCond (AnnSch tn)++delByCond :: forall tn -> ToStar tn+ => Connection -> Cond Sch (TS tn) -> IO (Int64, (Text,[SomeToField]))+delByCond tn = deleteByCond Sch (TS tn)++insJSON_+ :: forall tn -> forall r. (InsertTreeNonReturning (AnnSch tn) r)+ => Connection -> [r] -> IO Text+insJSON_ tn = insertJSON_ (AnnSch tn)++insJSON+ :: forall tn -> forall r r'. (InsertTreeReturning (AnnSch tn) r r')+ => Connection -> [r] -> IO ([r'], Text)+insJSON tn = insertJSON (AnnSch tn)++upsJSON_+ :: forall tn -> forall r. (UpsertTreeNonReturning (AnnSch tn) r)+ => Connection -> [r] -> IO Text+upsJSON_ tn = upsertJSON_ (AnnSch tn)++upsJSON+ :: forall tn -> forall r r'. (UpsertTreeReturning (AnnSch tn) r r')+ => Connection -> [r] -> IO ([r'], Text)+upsJSON tn = upsertJSON (AnnSch tn)++genDay :: Gen Day+genDay = ModifiedJulianDay . fromIntegral <$> Gen.int (Range.linear 50000 80000)++genTime :: Gen TimeOfDay+genTime = timeToTimeOfDay . fromIntegral <$> Gen.int (Range.linear 0 86399)++genLocalTime :: Gen LocalTime+genLocalTime = LocalTime <$> genDay <*> genTime++genUTCTime :: Gen UTCTime+genUTCTime = do+ day <- genDay+ diff <- fromIntegral <$> Gen.int (Range.linear 0 86399)+ pure $ UTCTime day diff++class GenDefault a where+ defGen :: Gen a+ default defGen :: (Generic a, GProdDefault (Rep a)) => Gen a+ defGen = to <$> gprodDefGen++class GProdDefault f where+ gprodDefGen :: Gen (f p)+instance GProdDefault U1 where+ gprodDefGen = pure U1+instance (GProdDefault f, GProdDefault g) => GProdDefault (f :*: g) where+ gprodDefGen = (:*:) <$> gprodDefGen <*> gprodDefGen+instance (GProdDefault f) => GProdDefault (M1 i meta f) where+ gprodDefGen = M1 <$> gprodDefGen+instance (GenDefault c) => GProdDefault (K1 i c) where+ gprodDefGen = K1 <$> defGen++instance GenDefault () where defGen = pure ()+instance GenDefault Int32 where defGen = Gen.int32 (Range.linear 0 1000000)+instance GenDefault Text where defGen = Gen.text (Range.linear 0 50) Gen.alpha+instance GenDefault Bool where defGen = Gen.bool+instance GenDefault Double where defGen = Gen.double $ Range.linearFrac 0 1000000+instance GenDefault Day where defGen = genDay+instance GenDefault TimeOfDay where defGen = genTime+instance GenDefault LocalTime where defGen = genLocalTime+instance GenDefault UTCTime where defGen = genUTCTime+instance GenDefault a => GenDefault (Maybe a) where defGen = Gen.maybe defGen++instance GenDefault a => GenDefault (PgArr a) where+ defGen = PgArr <$> Gen.list (Range.linear 0 5) defGen++instance GenDefault val => GenDefault (tag := val) where+ defGen = (tag =:) <$> defGen++instance (GenDefault h, GenDefault t) => GenDefault (h :. t) where+ defGen = (:.) <$> defGen <*> defGen++instance GenDefault (PGEnum Sch (TS "color")) where defGen = Gen.enumBounded++instance GenDefault Value where defGen = genValue++instance GenDefault (CI Text) where defGen = S.fromString . T.unpack <$> defGen++instance GenDefault (Binary BS.ByteString) where defGen = Binary <$> Gen.bytes (Range.linear 0 512)++instance GenDefault UUID where defGen = genUUID++genScientific :: Gen Scientific+genScientific =+ scientific+ <$> Gen.integral (Range.linear (-10000) 10000)+ <*> Gen.int (Range.linear (-10) 10)++genUUID :: Gen UUID+genUUID = do+ bytes <- Gen.bytes (Range.singleton 16)+ case fromByteString (BSL.fromStrict bytes) of+ Nothing -> error "Should never happen: 16 bytes is correct for UUID"+ Just u -> pure u++genValue :: Gen Value+genValue = Gen.recursive Gen.choice+ [ pure A.Null+ , Bool <$> Gen.bool+ , Number <$> genScientific+ , String <$> Gen.text (Range.linear 0 20) Gen.unicode+ ]+ [ Array . Vec.fromList <$> Gen.list (Range.linear 0 5) genValue+ , Object . KeyMap.fromList <$> Gen.list (Range.linear 0 5) genPair+ ]+ where+ genPair = (,) . Key.fromText+ <$> Gen.text (Range.linear 1 15) Gen.alpha+ <*> genValue++genData :: forall a -> GenDefault a => Gen [a]+genData a = genData' a 1 1000++instance GenDefault a => GenDefault [a] where+ defGen = genData' a 0 10++genData' :: forall a -> Int -> Int -> GenDefault a => Gen [a]+genData' a n1 n2 = Gen.list (Range.linear n1 n2) defGen+++--genIsoHList+-- :: forall tn r -> forall h.+-- ( IsoHList RenamerSch Sch (TS tn) r+-- , h ~ HList (HListRep RenamerSch Sch (TS tn) r)+-- , GenDefault h )+-- => Gen r+--genIsoHList tn r @h =+-- fromHList @RenamerSch @Sch @(TS tn) @r <$> (defGen :: Gen h)+--+--genDataH+-- :: forall tn r -> forall h+-- . ( IsoHList RenamerSch Sch (TS tn) r+-- , h ~ HList (HListRep RenamerSch Sch (TS tn) r)+-- , GenDefault h )+-- => Int -> Int -> Gen [r]+--genDataH tn r n1 n2 = Gen.list (Range.linear n1 n2) $ genIsoHList tn r
+ test/PgTagJsonSpec.hs view
@@ -0,0 +1,114 @@+-- | JSON encode/decode checks for `PgTag ann r` (replaces legacy HList doctest tests).+module PgTagJsonSpec (runTests) where++import Control.Monad (unless)+import Data.Aeson (Result (..), decode, encode, fromJSON, toJSON)+import Data.ByteString.Lazy.Char8 (pack)+import Data.Text (Text)+import GHC.Int (Int16)+import PgSchema.DML+import PgSchema.Schema.Catalog (PGC, PgCatalog)+import PgSchema.Schema.Info (PgClassShort (..), PgEnum (..), PgRelation (..))++data RenSnake :: Renamer++type instance ApplyRenamer RenSnake s = CamelToSnake s++type AnnCons = 'Ann RenSnake PgCatalog 3 (PGC "pg_constraint")++type AnnEnum = 'Ann RenSnake PgCatalog 3 (PGC "pg_enum")++runTests :: IO ()+runTests = do+ pgEnumEncodeShape+ pgEnumDecodeRoundTrip+ pgEnumMissingKeyRejected+ pgEnumExtraKeysIgnored+ pgConstraintJsonRoundTrip+ pgConstraintDuplicateFieldRoundTrip+ putStrLn "PgTag JSON (Ann / PgCatalog / CamelToSnake) checks passed."++-- | Stable field order follows Generics: @enumlabel@ then @enumsortorder@.+pgEnumEncodeShape :: IO ()+pgEnumEncodeShape = do+ let+ val :: PgTag AnnEnum PgEnum+ val = PgTag PgEnum { enumlabel = "lbl", enumsortorder = 42 :: Double }+ enc = encode val+ unless+ ( enc+ == pack "{\"enumlabel\":\"lbl\",\"enumsortorder\":42}"+ || enc == pack "{\"enumlabel\":\"lbl\",\"enumsortorder\":42.0}"+ )+ $ error $ "PgEnum encode: got " ++ show enc++pgEnumDecodeRoundTrip :: IO ()+pgEnumDecodeRoundTrip = do+ let+ val :: PgTag AnnEnum PgEnum+ val = PgTag PgEnum { enumlabel = "a", enumsortorder = 1.5 }+ case decode (encode val) of+ Nothing -> error "PgEnum decode: expected Just"+ Just v ->+ unless (v == val)+ $ error $ "PgEnum decode: got " ++ show v++pgEnumMissingKeyRejected :: IO ()+pgEnumMissingKeyRejected =+ case decode @(PgTag AnnEnum PgEnum) (pack "{\"enumsortorder\":1}") of+ Just _ -> error "PgEnum: expected decode failure for missing enumlabel"+ Nothing -> pure ()++pgEnumExtraKeysIgnored :: IO ()+pgEnumExtraKeysIgnored = do+ let+ val :: PgTag AnnEnum PgEnum+ val = PgTag PgEnum { enumlabel = "x", enumsortorder = 1 :: Double }+ case decode (pack "{\"enumlabel\":\"x\",\"enumsortorder\":1,\"extra\":99}") of+ Nothing -> error "PgEnum extra keys: expected Just"+ Just v ->+ unless (v == val)+ $ error $ "PgEnum extra keys: got " ++ show v++pgConstraintJsonRoundTrip :: IO ()+pgConstraintJsonRoundTrip = do+ let+ rel :: PgRelation+ rel =+ PgRelation+ { constraint__namespace = "nspname" =: ("a" :: Text)+ , conname = "b"+ , constraint__class = PgClassShort ("nspname" =: ("c" :: Text)) "d"+ , constraint__fclass = PgClassShort ("nspname" =: ("e" :: Text)) "f"+ , conkey = pgArr' [1 :: Int16, 2]+ , confkey = pgArr' []+ }+ tagged :: PgTag AnnCons PgRelation+ tagged = PgTag rel+ case fromJSON (toJSON tagged) of+ Error e -> error $ "PgRelation fromJSON: " ++ e+ Success r ->+ unless (r == tagged)+ $ error $ "PgRelation round-trip: got " ++ show r++pgConstraintDuplicateFieldRoundTrip :: IO ()+pgConstraintDuplicateFieldRoundTrip = do+ let+ rel :: PgRelation+ rel =+ PgRelation+ { constraint__namespace = "nspname" =: ("a" :: Text)+ , conname = "b"+ , constraint__class = PgClassShort ("nspname" =: ("c" :: Text)) "d"+ , constraint__fclass = PgClassShort ("nspname" =: ("e" :: Text)) "f"+ , conkey = pgArr' [1 :: Int16, 2]+ , confkey = pgArr' []+ }+ r = "conname" =: ("x" :: Text) :. "conname" =: ("z" :: Text)+ :. rel :. "conname" =: ("y" :: Text)+ tagged = PgTag @AnnCons r+ case fromJSON (toJSON tagged) of+ Error e -> error $ "PgRelation duplicate conname fromJSON: " ++ e+ Success res ->+ unless (res == tagged)+ $ error $ "PgRelation duplicate conname round-trip: got " ++ show res
+ test/json-spec.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import PgTagJsonSpec (runTests)++main :: IO ()+main = runTests