pg-schema 0.8.0.0 → 0.8.0.1
raw patch · 17 files changed
+87/−152 lines, 17 filesdep −unordered-containersdep ~basedep ~bytestringdep ~directoryPVP ok
version bump matches the API change (PVP)
Dependencies removed: unordered-containers
Dependency ranges changed: base, bytestring, directory, hashable, postgresql-simple, singletons
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- README.md +2/−2
- pg-schema.cabal +46/−80
- src/PgSchema/Ann.hs +1/−0
- src/PgSchema/DML.hs +0/−1
- src/PgSchema/Schema.hs +1/−0
- src/PgSchema/Utils/TF.hs +1/−1
- test-gen/Main.hs +1/−1
- test-pgs/Sch.hs +5/−1
- test-pgs/Tests/BaseConverts.hs +3/−11
- test-pgs/Tests/Conditions.hs +4/−5
- test-pgs/Tests/Hierarchy.hs +12/−19
- test-pgs/Tests/InsertJSONTransaction.hs +3/−4
- test-pgs/Tests/KeyedDML.hs +0/−2
- test-pgs/Tests/UpsertUniqueKey.hs +0/−1
- test-pgs/Utils.hs +3/−24
- test/PgTagJsonSpec.hs +1/−0
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for pg-schema +## 0.8.0.1+- Build all with -Wall+- Small fixes in doc+ ## 0.8.0.0 - Fix SELECT path matching after renamer: promoted `PathElem'` (`peName`,
README.md view
@@ -1,6 +1,6 @@ # 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.+[*pg-schema*](https://hackage-content.haskell.org/package/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. @@ -10,7 +10,7 @@ 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.+SELECT and INSERT/UPDATE/UPSERT are implemented for the nested structures. There are also versions of UPDATE and DELETE applied to a single table. When reading data, an EDSL sets conditions, ordering, and grouping. All of these operations are type-safe.
pg-schema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.12 name: pg-schema-version: 0.8.0.0+version: 0.8.0.1 category: Database author: Dmitry Olshansky maintainer: olshanskydr@gmail.com@@ -119,7 +119,37 @@ manual: True default: False +common shared+ build-depends:+ base >= 4.20 && < 5+ , bytestring >= 0.10 && < 0.13+ 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+ ghc-options:+ -Wall+ -Wunused-packages+ library+ import: shared exposed-modules: -- PgSchema PgSchema.DML@@ -154,15 +184,13 @@ PackageInfo_pg_schema hs-source-dirs: src build-depends:- base >= 4.20 && < 5- , aeson >= 2.0 && < 2.3- , bytestring >= 0.10 && < 0.13+ aeson >= 2.0 && < 2.3 , containers >= 0.7 && < 0.9 , directory >= 1.3 && < 1.5 , exceptions >= 0.9 && < 0.11 , mtl >= 2.0 && < 2.4- , postgresql-libpq >= 0.11 && < 0.12 , postgresql-simple >= 0.6 && < 0.8+ , postgresql-libpq >= 0.11 && < 0.12 , scientific >= 0.2 && < 0.4 , singletons >= 3.0.3 && < 3.1 , singletons-th >= 3.4 && < 3.6@@ -192,37 +220,13 @@ 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+ import: shared type: exitcode-stdio-1.0 main-is: json-spec.hs other-modules: PgTagJsonSpec- -- Paths and PackageInfo Paths_pg_schema PackageInfo_pg_schema autogen-modules:@@ -230,25 +234,14 @@ PackageInfo_pg_schema hs-source-dirs: test build-depends:- base- , aeson- , bytestring+ aeson , pg-schema- , postgresql-libpq >= 0.11 && < 0.12- , postgresql-simple >= 0.6 && < 0.8 , text- default-language: GHC2021- default-extensions:- DataKinds- OverloadedStrings- RequiredTypeArguments- TypeAbstractions- TypeFamilies- UndecidableInstances- ghc-options: -Wall test-suite test-gen+ import: shared type: exitcode-stdio-1.0+ hs-source-dirs: test-gen main-is: Main.hs other-modules: -- Paths and PackageInfo@@ -258,17 +251,13 @@ Paths_pg_schema PackageInfo_pg_schema build-depends:- base >= 4.20 && < 5- , bytestring >= 0.12.2 && < 0.13- , directory >= 1.3.9 && < 1.4- , pg-schema- , postgresql-libpq >= 0.11 && < 0.12+ pg-schema , postgresql-simple >= 0.6 && < 0.8- hs-source-dirs: test-gen- default-language: GHC2021 test-suite test-pgs+ import: shared type: exitcode-stdio-1.0+ hs-source-dirs: test-pgs main-is: Main.hs other-modules: Sch@@ -287,47 +276,24 @@ 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,+ pg-schema,+ postgresql-simple >= 0.6 && < 0.8, 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+ if flag(hashable)+ build-depends:+ hashable >= 1.5.1 && < 1.6+ cpp-options: -DMK_HASHABLE
src/PgSchema/Ann.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-} module PgSchema.Ann where import Data.Aeson
src/PgSchema/DML.hs view
@@ -108,7 +108,6 @@ -- - For upsert you need all mandatory fields _and_ some key. -- -- You can get in return any subset of the columns of the table which was affected by the operation.- -- All rows returned in the same order as the input tree. -- For update you get `Maybe t`. It is `Nothing` if the row was not found by the key. -- -- All these constraints are checked at compile time.
src/PgSchema/Schema.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TemplateHaskell #-} module PgSchema.Schema where import Data.List as L
src/PgSchema/Utils/TF.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module PgSchema.Utils.TF where -import Data.Singletons+import Data.Singletons ( Apply, type (~>) ) import GHC.TypeLits
test-gen/Main.hs view
@@ -16,7 +16,7 @@ connStr <- maybe "dbname=schema_test" BS.pack <$> lookupEnv "PG_CONN" bracket (connectPostgreSQL connStr) close $ \conn -> do putStrLn "Setting up schema..."- execute_ conn """+ void $ 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;
test-pgs/Sch.hs view
@@ -1,4 +1,5 @@ {- HLINT ignore -}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -10,7 +11,9 @@ -- This file is generated and can't be edited. import Control.DeepSeq+#ifdef MK_HASHABLE import Data.Hashable+#endif import GHC.Generics import GHC.TypeError qualified as TE import GHC.TypeLits qualified as TL@@ -21,7 +24,9 @@ = Color_red | Color_green | Color_blue deriving (Show, Read, Ord, Eq, Generic, Bounded, Enum) +#ifdef MK_HASHABLE instance Hashable (PGEnum Sch ( "test_pgs" ->> "color" ))+#endif instance NFData (PGEnum Sch ( "test_pgs" ->> "color" )) @@ -388,4 +393,3 @@ ,( "pg_catalog" ->> "timestamptz" ),( "pg_catalog" ->> "uuid" ) ,( "public" ->> "_citext" ),( "public" ->> "citext" ) ,( "test_pgs" ->> "_color" ),( "test_pgs" ->> "color" ) ]-
test-pgs/Tests/BaseConverts.hs view
@@ -1,25 +1,17 @@ {-# 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 as H import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range@@ -70,7 +62,7 @@ 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.sort resUpd === L.sort ((\(a:._:.c) -> a:. "cint4" =: Just (10::Int32) :.c) <$> L.filter (\(PgTag a:._) -> a == Just False) recs) prop_base_arr_converts :: Pool Connection -> Property@@ -102,7 +94,7 @@ 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.sort resUpd === L.sort ((\(_:.b) -> "ccitext" =: Just ("cAses" :: CI Text) :.b) <$> L.filter (\(_ :. PgTag a :. _) -> a == Just Color_red) recs) prop_ext_arr_converts :: Pool Connection -> Property@@ -114,7 +106,7 @@ prop_ext_converts_json_string_via_upsertjson :: Pool Connection -> Property prop_ext_converts_json_string_via_upsertjson pool = withTests 1 $ property do (sql, outSel) <- evalIO $ withPool pool \conn -> do- delByCond "ext_converts" conn mempty+ void $ delByCond "ext_converts" conn mempty sql' <- upsJSON_ "ext_converts" conn recs (xs, _) <- selSch "ext_converts" conn qpEmpty pure (sql', xs)
test-pgs/Tests/Conditions.hs view
@@ -17,7 +17,6 @@ import Database.PostgreSQL.Simple import GHC.Generics (Generic) import GHC.Int-import GHC.Stack (HasCallStack) import Hedgehog import PgSchema.DML import Utils@@ -84,10 +83,10 @@ :. "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 $ delByCond "leaf" conn mempty+ void $ delByCond "mid1" conn mempty+ void $ delByCond "mid2" conn mempty+ void $ delByCond "root" conn mempty void $ insJSON_ "root" conn inIns pure inIns
test-pgs/Tests/Hierarchy.hs view
@@ -5,25 +5,18 @@ {-# LANGUAGE NoFieldSelectors #-} module Tests.Hierarchy where -import Control.Monad (void) import Data.Coerce (coerce) import Data.Function (on) import Data.Functor-import Data.Int (Int32, Int64)+import Data.Int (Int32) import Data.List qualified as L-import Data.Maybe (fromMaybe, isJust, mapMaybe, catMaybes)+import Data.Maybe (isJust, catMaybes) 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 Hedgehog.Gen qualified as Gen-import Hedgehog.Range qualified as Range import PgSchema.DML-import Sch import Utils @@ -73,7 +66,7 @@ -- 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)+eqRoot (a1 :. b1 :. _) (a2 :. b2 :. _) = (a1, b1) == (a2, b2) rootKey :: RootRec -> (Text, Int32) rootKey (c :. g :. _ :. _) = (coerce c, coerce g)@@ -114,8 +107,8 @@ 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+ void $ delByCond "mid1" conn mempty+ void $ delByCond "root" conn mempty (fst -> (outIns' :: ["id" := Int32 :. "mid1RootFk" := ["id" := Int32 :. Mid1Rec]])) <- insJSON "root" conn inIns (fst -> (outSel1' :: ["id" := Int32 :. "mid1RootFk" := [Mid1Rec] :. RootRec])) <-@@ -148,8 +141,8 @@ 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+ void $ delByCond "mid2" conn mempty+ void $ 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])) <-@@ -181,8 +174,8 @@ 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+ void $ delByCond "mid2" conn mempty+ void $ 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])) <-@@ -198,9 +191,9 @@ leafIn <- forAll (L.nubBy ((==) `on` (.leafNo)) <$> genData' LeafI 0 10) let inIns = rootsIn <&> (("mid2_root_fk" =: (mid2In <&> (("leaf_mid2_fk" =: leafIn) :.))) :.) (outSel', outSel'') <- evalIO $ withPool pool \conn -> do- delByCond "leaf" conn mempty- delByCond "mid2" conn mempty- delByCond "root" conn mempty+ void $ delByCond "leaf" conn mempty+ void $ delByCond "mid2" conn mempty+ void $ delByCond "root" conn mempty void $ insJSON_ "root" conn inIns (fst -> (outSel' :: [Leaf])) <- selSch "leaf" conn qpEmpty (fst -> (outSel'' :: [LeafI :. "leaf_mid2_fk" := Mid2Rec])) <- selSch "leaf" conn qpEmpty
test-pgs/Tests/InsertJSONTransaction.hs view
@@ -3,7 +3,6 @@ import Control.Exception (SomeException, try) import Control.Monad (void, when)-import Data.Functor import Data.Int (Int32, Int64) import Data.List qualified as L import Data.Pool as Pool@@ -18,7 +17,7 @@ type RootSel = "code" := Text :. "grp" := Int32 :. "name" := Text eqRoot :: RootRec -> RootRec -> Bool-eqRoot (a1 :. b1 :. c1) (a2 :. b2 :. c2) = (a1, b1) == (a2, b2)+eqRoot (a1 :. b1 :. _) (a2 :. b2 :. _) = (a1, b1) == (a2, b2) countRoots :: Connection -> IO Int64 countRoots conn = do@@ -50,7 +49,7 @@ evalIO do Pool.withResource pool clearRoots Pool.withResource pool \conn -> do- execute_ conn "begin"+ void $ execute_ conn "begin" void $ insJSON_ "root" conn rootsIn n <- countRoots conn when (n /= fromIntegral (length rootsIn)) $@@ -72,7 +71,7 @@ evalIO do Pool.withResource pool clearRoots Pool.withResource pool \conn -> do- execute_ conn "begin"+ void $ execute_ conn "begin" void $ insJSON_ "root" conn rootsIn rollback conn Pool.withResource pool \conn -> do
test-pgs/Tests/KeyedDML.hs view
@@ -7,7 +7,6 @@ import Control.Monad (void, when, unless) import Data.Int (Int32) import Data.List qualified as L-import Data.Maybe (Maybe(..)) import Data.Pool as Pool import Data.Text (Text) import Data.Text qualified as T@@ -16,7 +15,6 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PgSchema.DML-import Sch import Utils type RootRec =
test-pgs/Tests/UpsertUniqueKey.hs view
@@ -3,7 +3,6 @@ import Control.Monad (void, when) import Data.Int (Int32)-import Data.Maybe (Maybe(..)) import Data.List qualified as L import Data.Pool as Pool import Data.Text (Text)
test-pgs/Utils.hs view
@@ -13,7 +13,6 @@ 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@@ -22,7 +21,6 @@ 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@@ -30,7 +28,6 @@ import Prelude as P import PgSchema.DML import Sch-import GHC.TypeLits (KnownSymbol) type TS tab = "test_pgs" ->> tab@@ -144,8 +141,8 @@ genUTCTime :: Gen UTCTime genUTCTime = do day <- genDay- diff <- fromIntegral <$> Gen.int (Range.linear 0 86399)- pure $ UTCTime day diff+ dt <- fromIntegral <$> Gen.int (Range.linear 0 86399)+ pure $ UTCTime day dt class GenDefault a where defGen :: Gen a@@ -228,22 +225,4 @@ 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+genData' _a n1 n2 = Gen.list (Range.linear n1 n2) defGen
test/PgTagJsonSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} -- | JSON encode/decode checks for `PgTag ann r` (replaces legacy HList doctest tests). module PgTagJsonSpec (runTests) where