pg-schema 0.5.1.1 → 0.5.2.0
raw patch · 5 files changed
+76/−9 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- pg-schema.cabal +1/−1
- src/PgSchema/Ann.hs +8/−4
- test-pgs/Main.hs +2/−0
- test-pgs/Tests/Hierarchy.hs +61/−4
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for pg-schema +## 0.5.2.0++- Bug fixing (Problem with Self-references)+ ## 0.5.1.1 - Improve error messaging
pg-schema.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.12 name: pg-schema-version: 0.5.1.1+version: 0.5.2.0 category: Database author: Dmitry Olshansky maintainer: olshanskydr@gmail.com
src/PgSchema/Ann.hs view
@@ -147,9 +147,9 @@ 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+ ColFI ('Ann ren sch d _) fld fd t = '[ 'ColInfo '(fld, 0) t (ApplyRenamer ren fld) fd ] -------------------------------------------------------------------------------- -- GCols (closed TF: Generic Rep) --------------------------------------------------------------------------------@@ -309,6 +309,9 @@ instance ToJSON (PgTag ann r) => ToField (PgTag (ann :: Ann) r) where toField = toJSONField +-- instance ToJSON (PgTag ann r) => ToField (Maybe (PgTag (ann :: Ann) r)) where+-- toField = toJSONField+ instance ToJSON (PgTag ann r) => ToField [PgTag (ann :: Ann) r] where toField = toJSONField @@ -316,6 +319,10 @@ => FromField (PgTag (ann :: Ann) r) where fromField = fromJSONField +-- instance (FromJSON (PgTag ann r), Typeable ann, Typeable r)+-- => FromField (Maybe (PgTag (ann :: Ann) r)) where+-- fromField = fromJSONField+ instance (FromJSON (PgTag ann r), Typeable ann, Typeable r) => FromField [PgTag (ann :: Ann) r] where fromField = fromJSONField@@ -448,9 +455,6 @@ 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)
test-pgs/Main.hs view
@@ -31,6 +31,8 @@ , 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+ , testProperty "Optional parent FK on root (dim_a_id)" $+ prop_hier_insert_optional_parent_dim_a pool ] , testGroup "Query (test_dml)" [ testProperty "'Simple' queries" $ prop_cond_query pool
test-pgs/Tests/Hierarchy.hs view
@@ -6,11 +6,12 @@ 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.List qualified as L-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Data.Pool as Pool import Data.Proxy (Proxy(..)) import Data.Text (Text)@@ -19,6 +20,8 @@ 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@@ -26,6 +29,16 @@ type RootRec = "code" := Text :. "grp" := Int32 :. "name" := Text :. "someEmpty" := () +type DimRec = "name" := Text++-- | Plain root row for insertSch: mandatory fields, optional @dim_a_id@ / @dim_b_id@.+type RootPlainDimA =+ "code" := Text+ :. "grp" := Int32+ :. "name" := Text+ :. "dim_a_id" := Maybe Int32+ :. "dim_b_id" := Maybe Int32+ type Mid1Rec = "flag" := Bool :. "pos" := Int32 :. "sortKey" := Int32 :. "payload" := Maybe Text @@ -68,6 +81,47 @@ eqRoot :: RootRec -> RootRec -> Bool eqRoot (a1 :. b1 :. c1) (a2 :. b2 :. c2) = (a1, b1) == (a2, b2) +rootKey :: RootRec -> (Text, Int32)+rootKey (c :. g :. _ :. _) = (coerce c, coerce g)++-- | Nullable FK @dim_a_id@ (optional link to @dim@); plain @insSch@ because @insertJSON@+-- lacks working @ToJSON@ for @Maybe (PgTag …)@ on Generic records here.+prop_hier_insert_optional_parent_dim_a :: Pool Connection -> Property+prop_hier_insert_optional_parent_dim_a pool = withTests 30 $ property do+ rootsIn <- forAll (L.nubBy eqRoot <$> genData' RootRec 1 80)+ useDim <- forAll (Gen.list (Range.linear (length rootsIn) (length rootsIn)) Gen.bool)+ dimOut <- forAll (genData' DimRec 1 30)+ outSel <- evalIO $ withPool pool \conn -> do+ delByCond "root" conn mempty+ delByCond "dim" conn mempty+ void $ insSch_ "dim" conn (dimOut :: [DimRec])+ (dimRows, _) <- selSch "dim" conn qpEmpty+ let dimIds =+ (dimRows :: ["id" := Int32 :. DimRec]) <&> \(i :. _) -> coerce i :: Int32+ plainIns :: [RootPlainDimA]+ plainIns =+ zipWith3+ (\(c :. g :. n :. _) wantDim k ->+ "code" =: coerce c+ :. "grp" =: coerce g+ :. "name" =: coerce n+ :. "dim_a_id"+ =: (if wantDim then Just (dimIds !! (k `mod` length dimIds)) else Nothing)+ :. "dim_b_id" =: Nothing)+ rootsIn+ useDim+ [(0 :: Int) ..]+ void $ insSch_ "root" conn plainIns+ (xs, _) <- selSch "root" conn qpEmpty+ pure (xs :: ["id" := Int32 :. "dim_a_id" := Maybe Int32 :. RootRec :. "root_dim_a_fk" := Maybe DimRec])+ let+ expected =+ L.sortOn (rootKey . fst) $ zip rootsIn useDim <&> \(r, u) -> (r, u)+ got =+ L.sortOn (rootKey . \(_ :. _ :. r :. _) -> r) outSel+ <&> \(_ :. PgTag dimA :. r :. _) -> (r, isJust dimA)+ expected === got+ 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)@@ -155,11 +209,14 @@ 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+ (outSel', 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 )+ (fst -> (outSel'' :: [LeafI :. "leaf_mid2_fk" := Mid2Rec])) <- selSch "leaf" conn qpEmpty++ pure (outSel', outSel'')+ L.length outSel' === L.length (inIns >>= \(PgTag xs :. _) -> xs >>= \(PgTag ys :. _) -> ys )+ L.length outSel'' === L.length outSel'