diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for pg-schema + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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`. diff --git a/pg-schema.cabal b/pg-schema.cabal new file mode 100644 --- /dev/null +++ b/pg-schema.cabal @@ -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 diff --git a/src/PgSchema/Ann.hs b/src/PgSchema/Ann.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Ann.hs @@ -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) diff --git a/src/PgSchema/DML.hs b/src/PgSchema/DML.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML.hs @@ -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) diff --git a/src/PgSchema/DML/Delete.hs b/src/PgSchema/DML/Delete.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Delete.hs @@ -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 diff --git a/src/PgSchema/DML/Insert.hs b/src/PgSchema/DML/Insert.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Insert.hs @@ -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 "," diff --git a/src/PgSchema/DML/Insert/Types.hs b/src/PgSchema/DML/Insert/Types.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Insert/Types.hs @@ -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' ) diff --git a/src/PgSchema/DML/InsertJSON.hs b/src/PgSchema/DML/InsertJSON.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/InsertJSON.hs @@ -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 diff --git a/src/PgSchema/DML/Select.hs b/src/PgSchema/DML/Select.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Select.hs @@ -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 } diff --git a/src/PgSchema/DML/Select/Types.hs b/src/PgSchema/DML/Select/Types.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Select/Types.hs @@ -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 (~~?) #-} +(?),(<=?),(>=?),(=?) + :: 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 +(~=?),(~~?) + :: 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 diff --git a/src/PgSchema/DML/Update.hs b/src/PgSchema/DML/Update.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/DML/Update.hs @@ -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 diff --git a/src/PgSchema/GenDot.hs b/src/PgSchema/GenDot.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/GenDot.hs @@ -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 diff --git a/src/PgSchema/Generation.hs b/src/PgSchema/Generation.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Generation.hs @@ -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 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 diff --git a/src/PgSchema/Import.hs b/src/PgSchema/Import.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Import.hs @@ -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 diff --git a/src/PgSchema/Schema.hs b/src/PgSchema/Schema.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Schema.hs @@ -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 diff --git a/src/PgSchema/Schema/Catalog.hs b/src/PgSchema/Schema/Catalog.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Schema/Catalog.hs @@ -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 diff --git a/src/PgSchema/Schema/Info.hs b/src/PgSchema/Schema/Info.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Schema/Info.hs @@ -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) diff --git a/src/PgSchema/Types.hs b/src/PgSchema/Types.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Types.hs @@ -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 =: diff --git a/src/PgSchema/Utils/CamelToSnake.hs b/src/PgSchema/Utils/CamelToSnake.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Utils/CamelToSnake.hs @@ -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 diff --git a/src/PgSchema/Utils/Instances.hs b/src/PgSchema/Utils/Instances.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Utils/Instances.hs @@ -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 diff --git a/src/PgSchema/Utils/Internal.hs b/src/PgSchema/Utils/Internal.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Utils/Internal.hs @@ -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 diff --git a/src/PgSchema/Utils/ShowType.hs b/src/PgSchema/Utils/ShowType.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Utils/ShowType.hs @@ -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" diff --git a/src/PgSchema/Utils/TF.hs b/src/PgSchema/Utils/TF.hs new file mode 100644 --- /dev/null +++ b/src/PgSchema/Utils/TF.hs @@ -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 diff --git a/test-gen/Main.hs b/test-gen/Main.hs new file mode 100644 --- /dev/null +++ b/test-gen/Main.hs @@ -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 diff --git a/test-pgs/Main.hs b/test-pgs/Main.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Main.hs @@ -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 + -- ] + ] diff --git a/test-pgs/Sch.hs b/test-pgs/Sch.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Sch.hs @@ -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" ) ] + diff --git a/test-pgs/Tests/Aggregates.hs b/test-pgs/Tests/Aggregates.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Tests/Aggregates.hs @@ -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 diff --git a/test-pgs/Tests/BaseConverts.hs b/test-pgs/Tests/BaseConverts.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Tests/BaseConverts.hs @@ -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 diff --git a/test-pgs/Tests/Conditions.hs b/test-pgs/Tests/Conditions.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Tests/Conditions.hs @@ -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" ? (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] diff --git a/test-pgs/Tests/Hierarchy.hs b/test-pgs/Tests/Hierarchy.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Tests/Hierarchy.hs @@ -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 ) diff --git a/test-pgs/Tests/Path.hs b/test-pgs/Tests/Path.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Tests/Path.hs @@ -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 diff --git a/test-pgs/Utils.hs b/test-pgs/Utils.hs new file mode 100644 --- /dev/null +++ b/test-pgs/Utils.hs @@ -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 diff --git a/test/PgTagJsonSpec.hs b/test/PgTagJsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/PgTagJsonSpec.hs @@ -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 diff --git a/test/json-spec.hs b/test/json-spec.hs new file mode 100644 --- /dev/null +++ b/test/json-spec.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import PgTagJsonSpec (runTests) + +main :: IO () +main = runTests