diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/pg-schema.cabal b/pg-schema.cabal --- a/pg-schema.cabal +++ b/pg-schema.cabal @@ -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 diff --git a/src/PgSchema/Ann.hs b/src/PgSchema/Ann.hs --- a/src/PgSchema/Ann.hs +++ b/src/PgSchema/Ann.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} module PgSchema.Ann where import Data.Aeson diff --git a/src/PgSchema/DML.hs b/src/PgSchema/DML.hs --- a/src/PgSchema/DML.hs +++ b/src/PgSchema/DML.hs @@ -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. diff --git a/src/PgSchema/Schema.hs b/src/PgSchema/Schema.hs --- a/src/PgSchema/Schema.hs +++ b/src/PgSchema/Schema.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TemplateHaskell #-} module PgSchema.Schema where import Data.List as L diff --git a/src/PgSchema/Utils/TF.hs b/src/PgSchema/Utils/TF.hs --- a/src/PgSchema/Utils/TF.hs +++ b/src/PgSchema/Utils/TF.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module PgSchema.Utils.TF where -import Data.Singletons +import Data.Singletons ( Apply, type (~>) ) import GHC.TypeLits diff --git a/test-gen/Main.hs b/test-gen/Main.hs --- a/test-gen/Main.hs +++ b/test-gen/Main.hs @@ -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; diff --git a/test-pgs/Sch.hs b/test-pgs/Sch.hs --- a/test-pgs/Sch.hs +++ b/test-pgs/Sch.hs @@ -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" ) ] - diff --git a/test-pgs/Tests/BaseConverts.hs b/test-pgs/Tests/BaseConverts.hs --- a/test-pgs/Tests/BaseConverts.hs +++ b/test-pgs/Tests/BaseConverts.hs @@ -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) diff --git a/test-pgs/Tests/Conditions.hs b/test-pgs/Tests/Conditions.hs --- a/test-pgs/Tests/Conditions.hs +++ b/test-pgs/Tests/Conditions.hs @@ -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 diff --git a/test-pgs/Tests/Hierarchy.hs b/test-pgs/Tests/Hierarchy.hs --- a/test-pgs/Tests/Hierarchy.hs +++ b/test-pgs/Tests/Hierarchy.hs @@ -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 diff --git a/test-pgs/Tests/InsertJSONTransaction.hs b/test-pgs/Tests/InsertJSONTransaction.hs --- a/test-pgs/Tests/InsertJSONTransaction.hs +++ b/test-pgs/Tests/InsertJSONTransaction.hs @@ -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 diff --git a/test-pgs/Tests/KeyedDML.hs b/test-pgs/Tests/KeyedDML.hs --- a/test-pgs/Tests/KeyedDML.hs +++ b/test-pgs/Tests/KeyedDML.hs @@ -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 = diff --git a/test-pgs/Tests/UpsertUniqueKey.hs b/test-pgs/Tests/UpsertUniqueKey.hs --- a/test-pgs/Tests/UpsertUniqueKey.hs +++ b/test-pgs/Tests/UpsertUniqueKey.hs @@ -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) diff --git a/test-pgs/Utils.hs b/test-pgs/Utils.hs --- a/test-pgs/Utils.hs +++ b/test-pgs/Utils.hs @@ -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 diff --git a/test/PgTagJsonSpec.hs b/test/PgTagJsonSpec.hs --- a/test/PgTagJsonSpec.hs +++ b/test/PgTagJsonSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} -- | JSON encode/decode checks for `PgTag ann r` (replaces legacy HList doctest tests). module PgTagJsonSpec (runTests) where