diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for beam-large-records +## 0.1.3 -- 2025-09-19 + +* Support for ghc 9.10 and 9.12 + ## 0.1.2 -- 2025-07-19 * Relax bounds (Gabriele Sales) diff --git a/beam-large-records.cabal b/beam-large-records.cabal --- a/beam-large-records.cabal +++ b/beam-large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: beam-large-records -version: 0.1.2 +version: 0.1.3 synopsis: Integration of large-records with beam-core. description: This package provides the necessary instances that make it possible to use records defined with large-records as @@ -12,10 +12,13 @@ category: Database extra-doc-files: CHANGELOG.md tested-with: GHC ==8.10.7 + GHC ==9.0.2 GHC ==9.2.8 GHC ==9.4.8 GHC ==9.6.7 GHC ==9.8.4 + GHC ==9.10.2 + GHC ==9.12.2 source-repository head type: git @@ -37,7 +40,7 @@ build-depends: -- lower bound on beam-core is necessary -- see https://github.com/haskell-beam/beam/issues/585 - base >= 4.14 && < 4.20 + base >= 4.14 && < 4.23 , beam-core >= 0.10.3.0 && < 0.11 , large-generics >= 0.2 && < 0.3 , microlens >= 0.4 && < 0.5 @@ -80,7 +83,6 @@ , beam-large-records , beam-sqlite , large-records - , microlens , record-hasfield , sqlite-simple , tasty @@ -93,6 +95,7 @@ , ghc-prim , large-generics , record-hasfield + , optics-core ghc-options: -Wall -Wredundant-constraints diff --git a/src/Data/Record/Beam/FromBackendRow.hs b/src/Data/Record/Beam/FromBackendRow.hs --- a/src/Data/Record/Beam/FromBackendRow.hs +++ b/src/Data/Record/Beam/FromBackendRow.hs @@ -44,7 +44,7 @@ perField = Rep.cpure (Proxy @(FromBackendRowI be)) (Comp fromBackendRowI) gValuesNeeded pBackend _ _ = - foldl' (+) 0 $ Rep.collapse perField + Data.List.foldl' (+) 0 $ Rep.collapse perField where perField :: Rep (K Int) (tbl Uninterpreted) perField = Rep.cpure (Proxy @(FromBackendRowI be)) (valuesNeededI pBackend) diff --git a/src/Data/Record/Beam/Lenses.hs b/src/Data/Record/Beam/Lenses.hs --- a/src/Data/Record/Beam/Lenses.hs +++ b/src/Data/Record/Beam/Lenses.hs diff --git a/src/Data/Record/Beam/ZipTables.hs b/src/Data/Record/Beam/ZipTables.hs --- a/src/Data/Record/Beam/ZipTables.hs +++ b/src/Data/Record/Beam/ZipTables.hs @@ -68,4 +68,3 @@ instance Beamable table => ZipBeamFieldsI (table (Nullable Uninterpreted)) where zipBeamFieldsI f = liftInterpretedA2 $ zipBeamFieldsM (liftNullableA2 f) - diff --git a/test/Test/Record/Beam/SimpleSQL.hs b/test/Test/Record/Beam/SimpleSQL.hs --- a/test/Test/Record/Beam/SimpleSQL.hs +++ b/test/Test/Record/Beam/SimpleSQL.hs @@ -14,8 +14,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- | Simple but complete example that does an SQL INSERT and SELECT module Test.Record.Beam.SimpleSQL ( @@ -29,6 +30,7 @@ import Data.Kind import Data.Text (Text) import Database.Beam +import Optics.Core ((^.)) import qualified Database.SQLite.Simple as SQLite import qualified GHC.Generics as GHC @@ -61,7 +63,7 @@ deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey tbl = LargeTableKey tbl.largeTableId + primaryKey tbl = LargeTableKey (tbl ^. #largeTableId) {------------------------------------------------------------------------------- The full database @@ -93,12 +95,12 @@ "CREATE TABLE db_large_table (table_id INT PRIMARY KEY NOT NULL, table_field VARCHAR NOT NULL);" runInsert $ - insert exampleDb.exampleDbLargeTable $ insertValues [ + insert (exampleDb ^. #exampleDbLargeTable) $ insertValues [ large1 , large2 ] allLarge <- runSelectReturningList $ select $ - orderBy_ (\x -> asc_ (x.largeTableId)) $ all_ exampleDb.exampleDbLargeTable + orderBy_ (\x -> asc_ (x ^. #largeTableId)) $ all_ (exampleDb ^. #exampleDbLargeTable) liftIO $ assertEqual "allLarge" allLarge [large1, large2] diff --git a/test/Test/Record/Beam/Tutorial1.hs b/test/Test/Record/Beam/Tutorial1.hs --- a/test/Test/Record/Beam/Tutorial1.hs +++ b/test/Test/Record/Beam/Tutorial1.hs @@ -15,8 +15,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Beam.Tutorial1 ( tests @@ -35,6 +36,7 @@ import Data.Text (Text) import Database.Beam hiding (Generic, countAll_) import Database.Beam.Schema.Tables +import Optics.Core ((^.)) import qualified Data.List.NonEmpty as NE import qualified Database.SQLite.Simple as SQLite @@ -79,11 +81,11 @@ sam3 = User "sam@jely.com" "Sam" "Jely" "332532dcfaa1cbf61e2a266bd723612c" instance Table UserT where - data PrimaryKey UserT f = UserId (Columnar f Text) + newtype PrimaryKey UserT f = UserId (Columnar f Text) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey tbl = UserId tbl.userEmail + primaryKey tbl = UserId (tbl ^. #userEmail) deriving instance Show (Columnar f Text) => Show (PrimaryKey UserT f) deriving instance Eq (Columnar f Text) => Eq (PrimaryKey UserT f) @@ -153,23 +155,23 @@ liftIO $ SQLite.execute_ conn $ "CREATE TABLE cart_users (email VARCHAR NOT NULL, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL, password VARCHAR NOT NULL, PRIMARY KEY( email ));" - runInsert $ insert shoppingCartDb.shoppingCartUsers $ insertValues [ + runInsert $ insert (shoppingCartDb ^. #shoppingCartUsers) $ insertValues [ james , betty , sam ] - let allUsers = all_ (shoppingCartDb.shoppingCartUsers) + let allUsers = all_ (shoppingCartDb ^. #shoppingCartUsers) users <- runSelectReturningList $ select allUsers liftIO $ assertEqual "users" [james, betty, sam] users - let sortUsersByFirstName = orderBy_ (\u -> (asc_ u.userFirstName, desc_ u.userLastName)) (all_ shoppingCartDb.shoppingCartUsers) + let sortUsersByFirstName = orderBy_ (\u -> (asc_ $ u ^. #userFirstName, desc_ $ u ^. #userLastName)) (all_ $ shoppingCartDb ^. #shoppingCartUsers) sorted <- runSelectReturningList $ select sortUsersByFirstName liftIO $ assertEqual "sorted" [betty, james, sam] sorted let boundedQuery = limit_ 1 $ offset_ 1 $ - orderBy_ (\u -> asc_ u.userFirstName) $ - all_ shoppingCartDb.shoppingCartUsers + orderBy_ (\u -> asc_ (u ^. #userFirstName)) $ + all_ (shoppingCartDb ^. #shoppingCartUsers) bounded <- runSelectReturningList (select boundedQuery) liftIO $ assertEqual "bounded" [james] bounded @@ -177,19 +179,19 @@ -- Tutorial has Int32 here, but that doesn't typecheck -- Don't think that is related to beam-large-records though..? -- (Maybe due to beam version mismatch between tutorial and our beam branch.) - let userCount = aggregate_ (\_u -> as_ @Int32 countAll_) (all_ shoppingCartDb.shoppingCartUsers) + let userCount = aggregate_ (\_u -> as_ @Int32 countAll_) (all_ (shoppingCartDb ^. #shoppingCartUsers)) Just c <- runSelectReturningOne $ select userCount liftIO $ assertEqual "userCount" 3 c - runInsert $ insert shoppingCartDb.shoppingCartUsers $ insertValues [ + runInsert $ insert (shoppingCartDb ^. #shoppingCartUsers) $ insertValues [ james2 , betty2 , james3 , sam2 , sam3 ] - let numberOfUsersByName = aggregate_ (\u -> (group_ u.userFirstName, as_ @Int32 countAll_)) $ - all_ shoppingCartDb.shoppingCartUsers + let numberOfUsersByName = aggregate_ (\u -> (group_ (u ^. #userFirstName), as_ @Int32 countAll_)) $ + all_ (shoppingCartDb ^. #shoppingCartUsers) countedByName <- runSelectReturningList $ select numberOfUsersByName liftIO $ assertEqual "countedByName" [("Betty",2), ("James",3), ("Sam",3)] countedByName @@ -197,7 +199,7 @@ -- (NOTE: RDS gets confused by nested multiline comments.) test_tutorial1_recordDotSyntax :: Assertion test_tutorial1_recordDotSyntax = - assertEqual "" "a@b.c" u.userEmail + assertEqual "" "a@b.c" (u ^. #userEmail) where u :: User u = User { diff --git a/test/Test/Record/Beam/Tutorial2.hs b/test/Test/Record/Beam/Tutorial2.hs --- a/test/Test/Record/Beam/Tutorial2.hs +++ b/test/Test/Record/Beam/Tutorial2.hs @@ -15,8 +15,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-} @@ -35,7 +36,7 @@ import Data.Text (Text) import Database.Beam import Database.Beam.Schema.Tables -import Lens.Micro +import Optics.Core ((&), (^.), (%~), (%), (.~), coerced) import qualified Data.List.NonEmpty as NE import qualified Data.Text as Text @@ -66,14 +67,13 @@ deriving anyclass (Beamable) type Address = AddressT Identity --- type AddressId = PrimaryKey AddressT Identity instance Table AddressT where data PrimaryKey AddressT f = AddressId (Columnar f Int32) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey addr = AddressId $ addr.addressId + primaryKey addr = AddressId $ addr ^. #addressId deriving instance Show (Columnar f Int32) => Show (PrimaryKey AddressT f) deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey AddressT f) @@ -104,69 +104,11 @@ shoppingCart2Db :: forall be. DatabaseSettings be ShoppingCart2Db shoppingCart2Db = defaultDbSettings `withDbModification` - dbModification{shoppingCart2UserAddresses = - setEntityName "addresses" + (dbModification & #shoppingCart2UserAddresses .~ + (setEntityName "addresses" <> modifyTableFields - tableModification{addressLine1 = fieldNamed "address1" - ,addressLine2 = fieldNamed "address2" - } - } - -{------------------------------------------------------------------------------- - Derive lenses - - TODO: Can we avoid the type signature on 'lensesAddressT' and co? --------------------------------------------------------------------------------} - -lensesAddressT :: AddressT (Lenses AddressT f) -lensesUserT :: UserT (Lenses UserT f) - -lensesAddressT = tableLenses -lensesUserT = tableLenses - -lensesShoppingCart2 :: ShoppingCart2Db (TableLens f ShoppingCart2Db) -lensesShoppingCart2 = dbLenses - -xaddressId :: Lens' (AddressT f) (Columnar f Int32) -xaddressId = case lensesAddressT.addressId of LensFor x -> x - -xaddressLine1 :: Lens' (AddressT f) (Columnar f Text) -xaddressLine1 = case lensesAddressT.addressLine1 of LensFor x -> x - -xaddressLine2 :: Lens' (AddressT f) (Columnar f (Maybe Text)) -xaddressLine2 = case lensesAddressT.addressLine2 of LensFor x -> x - -xaddressCity :: Lens' (AddressT f) (Columnar f Text) -xaddressCity = case lensesAddressT.addressCity of LensFor x -> x - -xaddressState :: Lens' (AddressT f) (Columnar f Text) -xaddressState = case lensesAddressT.addressState of LensFor x -> x - -xaddressZip :: Lens' (AddressT f) (Columnar f Text) -xaddressZip = case lensesAddressT.addressZip of LensFor x -> x - -xaddressForUserId :: Lens' (AddressT f) (Columnar f Text) -xaddressForUserId = case lensesAddressT.addressForUser of UserId (LensFor x) -> x - - -xuserEmail :: Lens' (UserT f) (Columnar f Text) -xuserEmail = case lensesUserT.userEmail of LensFor x -> x - -xuserFirstName :: Lens' (UserT f) (Columnar f Text) -xuserFirstName = case lensesUserT.userFirstName of LensFor x -> x - -xuserLastName :: Lens' (UserT f) (Columnar f Text) -xuserLastName = case lensesUserT.userLastName of LensFor x -> x - -xuserPassword :: Lens' (UserT f) (Columnar f Text) -xuserPassword = case lensesUserT.userPassword of LensFor x -> x - - -xshoppingCart2Users :: Lens' (ShoppingCart2Db f) (f (TableEntity UserT)) -xshoppingCart2Users = case lensesShoppingCart2.shoppingCart2Users of TableLens x -> x - -xshoppingCart2UserAddresses :: Lens' (ShoppingCart2Db f) (f (TableEntity AddressT)) -xshoppingCart2UserAddresses = case lensesShoppingCart2.shoppingCart2UserAddresses of TableLens x -> x + (tableModification & #addressLine1 .~ fieldNamed "address1" + & #addressLine2 .~ fieldNamed "address2"))) {------------------------------------------------------------------------------- Tests proper @@ -220,22 +162,22 @@ test_tableLenses :: Assertion test_tableLenses = do assertEqual "get" expectedGet $ - exampleAddress ^. xaddressId + exampleAddress ^. #addressId assertEqual "set" expectedSet $ - exampleAddress & xaddressForUserId %~ Text.toUpper + exampleAddress & #addressForUser % coerced %~ Text.toUpper where expectedGet :: Int32 expectedGet = 1 expectedSet :: Address - expectedSet = exampleAddress{addressForUser = UserId "A@B.C"} + expectedSet = exampleAddress & #addressForUser .~ UserId "A@B.C" test_dbLenses :: Assertion test_dbLenses = do assertEqual "get" expectedGet $ - exampleDb ^. xshoppingCart2Users + exampleDb ^. #shoppingCart2Users assertEqual "set" expectedSet $ - exampleDb & xshoppingCart2UserAddresses %~ (\(Const n) -> Const (n + 1)) + exampleDb & #shoppingCart2UserAddresses %~ (\(Const n) -> Const (n + 1)) where expectedGet :: Const Int a expectedGet = Const 1 @@ -245,7 +187,7 @@ shoppingCart2Users = Const 1 , shoppingCart2UserAddresses = Const 2 } - expectedSet = exampleDb{shoppingCart2UserAddresses = Const 3} + expectedSet = exampleDb & #shoppingCart2UserAddresses .~ Const 3 test_SQL :: Assertion test_SQL = runInMemory $ \conn -> do @@ -254,16 +196,16 @@ liftIO $ SQLite.execute_ conn $ "CREATE TABLE addresses ( id INTEGER PRIMARY KEY, address1 VARCHAR NOT NULL, address2 VARCHAR, city VARCHAR NOT NULL, state VARCHAR NOT NULL, zip VARCHAR NOT NULL, for_user__email VARCHAR NOT NULL );" - runInsert $ insert shoppingCart2Db.shoppingCart2Users $ + runInsert $ insert (shoppingCart2Db ^. #shoppingCart2Users) $ insertValues [ james, betty, sam ] - runInsert $ insert shoppingCart2Db.shoppingCart2UserAddresses $ + runInsert $ insert (shoppingCart2Db ^. #shoppingCart2UserAddresses) $ insertExpressions addresses -- Straight-forward SELECT -- (Checks that primary keys have been assigned correctly) addressesActual <- runSelectReturningList $ - select (all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)) + select (all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses)) liftIO $ assertEqual "addresses" addressesExpected addressesActual @@ -271,9 +213,9 @@ -- Simple JOIN usersAndRelatedAddressesActual <- runSelectReturningList $ select $ do - user <- all_ (shoppingCart2Db ^. xshoppingCart2Users) - address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) - guard_ (address ^. xaddressForUserId ==. user ^. xuserEmail) + user <- all_ (shoppingCart2Db ^. #shoppingCart2Users) + address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) + guard_ (address ^. #addressForUser % coerced ==. user ^. #userEmail) return (user, address) liftIO $ assertEqual "usersAndRelatedAddresses" usersAndRelatedAddressesExpected @@ -282,9 +224,9 @@ -- Alternative way to write the same JOIN usersAndRelatedAddressesUsingReferences <- runSelectReturningList $ select $ do - user <- all_ (shoppingCart2Db ^. xshoppingCart2Users) - address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) - guard_ (address.addressForUser `references_` user) + user <- all_ (shoppingCart2Db ^. #shoppingCart2Users) + address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) + guard_ ((address ^. #addressForUser) `references_` user) pure (user, address) liftIO $ assertEqual "usersAndRelatedAddressesUsingReferences" usersAndRelatedAddressesExpected @@ -293,8 +235,8 @@ -- Using ON usersAndRelatedAddressesUsingRelated <- runSelectReturningList $ select $ do - address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) - user <- related_ (shoppingCart2Db ^. xshoppingCart2Users) address.addressForUser + address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) + user <- related_ (shoppingCart2Db ^. #shoppingCart2Users) (address ^. #addressForUser) pure (user, address) liftIO $ assertEqual "usersAndRelatedAddressesUsingRelated" usersAndRelatedAddressesExpected @@ -303,47 +245,47 @@ -- WHERE on a foreign key bettysAddresses <- runSelectReturningList $ select $ do - address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) - guard_ (address.addressForUser ==. val_ bettyId) + address <- all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) + guard_ (address ^. #addressForUser ==. val_ bettyId) pure address liftIO $ assertEqual "bettysAddresses" [addr2, addr3] bettysAddresses -- Simple UPDATE - runUpdate $ save (shoppingCart2Db ^. xshoppingCart2Users) $ - james{userPassword = superSecure} + runUpdate $ save (shoppingCart2Db ^. #shoppingCart2Users) $ + james & #userPassword .~ superSecure [james'] <- runSelectReturningList $ - lookup_ (shoppingCart2Db ^. xshoppingCart2Users) jamesId + lookup_ (shoppingCart2Db ^. #shoppingCart2Users) jamesId liftIO $ assertEqual "James' new password" superSecure - (james' ^. xuserPassword) + (james' ^. #userPassword) -- More granular UPDATE - runUpdate $ update (shoppingCart2Db ^. xshoppingCart2UserAddresses) + runUpdate $ update (shoppingCart2Db ^. #shoppingCart2UserAddresses) (\address -> mconcat [ - address ^. xaddressCity <-. val_ "Sugarville" - , address ^. xaddressZip <-. val_ "12345" + address ^. #addressCity <-. val_ "Sugarville" + , address ^. #addressZip <-. val_ "12345" ] ) (\address -> - address ^. xaddressCity ==. val_ "Sugarland" - &&. address ^. xaddressState ==. val_ "TX" + address ^. #addressCity ==. val_ "Sugarland" + &&. address ^. #addressState ==. val_ "TX" ) updatedAddresses <- runSelectReturningList $ - select $ all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) + select $ all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) liftIO $ assertEqual "updatedAddresses" [addr1, addr2, addr3'] updatedAddresses -- DELETE - runDelete $ delete (shoppingCart2Db ^. xshoppingCart2UserAddresses) + runDelete $ delete (shoppingCart2Db ^. #shoppingCart2UserAddresses) (\address -> - address ^. xaddressCity ==. "Houston" - &&. address.addressForUser `references_` val_ betty + address ^. #addressCity ==. "Houston" + &&. (address ^. #addressForUser) `references_` val_ betty ) afterDelete <- runSelectReturningList $ - select $ all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses) + select $ all_ (shoppingCart2Db ^. #shoppingCart2UserAddresses) liftIO $ assertEqual "afterDelete" [addr1, addr3'] afterDelete diff --git a/test/Test/Record/Beam/Tutorial3.hs b/test/Test/Record/Beam/Tutorial3.hs --- a/test/Test/Record/Beam/Tutorial3.hs +++ b/test/Test/Record/Beam/Tutorial3.hs @@ -15,8 +15,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- For lens derivation -- {-# LANGUAGE ImpredicativeTypes #-} @@ -33,7 +34,7 @@ import Database.Beam hiding (countAll_) import Database.Beam.Backend.SQL import Database.Beam.Sqlite -import Lens.Micro +import Optics.Core ((&), (^.), (.~), (%), coerced, Lens') import qualified Data.Text as T import qualified Database.SQLite.Simple as SQLite @@ -66,11 +67,11 @@ deriving anyclass (Beamable) instance Table ProductT where - data PrimaryKey ProductT f = ProductId (Columnar f Int32) + newtype PrimaryKey ProductT f = ProductId (Columnar f Int32) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey p = ProductId p.productId + primaryKey p = ProductId (p ^. #productId) deriving instance Show (Columnar f Int32) => Show (PrimaryKey ProductT f) deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey ProductT f) @@ -114,18 +115,18 @@ deriving anyclass (Beamable) instance Table OrderT where - data PrimaryKey OrderT f = OrderId (Columnar f Int32) + newtype PrimaryKey OrderT f = OrderId (Columnar f Int32) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey o = OrderId o.orderId + primaryKey o = OrderId (o ^. #orderId) instance Table ShippingInfoT where - data PrimaryKey ShippingInfoT f = ShippingInfoId (Columnar f Int32) + newtype PrimaryKey ShippingInfoT f = ShippingInfoId (Columnar f Int32) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey s = ShippingInfoId s.shippingInfoId + primaryKey s = ShippingInfoId (s ^. #shippingInfoId) deriving instance Show (Columnar f Int32) => Show (PrimaryKey OrderT f) deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey OrderT f) @@ -157,7 +158,7 @@ deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey l = LineItemId l.lineItemInOrder l.lineItemForProduct + primaryKey l = LineItemId (l ^. #lineItemInOrder) (l ^. #lineItemForProduct) {------------------------------------------------------------------------------- Version 3 of the DB @@ -180,105 +181,29 @@ -------------------------------------------------------------------------------} shoppingCart3Db :: DatabaseSettings be ShoppingCart3Db -shoppingCart3Db = defaultDbSettings `withDbModification` - dbModification{shoppingCart3UserAddresses = - setEntityName "addresses" - <> modifyTableFields tableModification{addressLine1 = "address1" - ,addressLine2 = "address2" - } - , shoppingCart3Products = - setEntityName "products" - , shoppingCart3Orders = - setEntityName "orders" - <> modifyTableFields tableModification{orderShippingInfo = ShippingInfoId "shipping_info__id"} - , shoppingCart3ShippingInfos = - setEntityName "shipping_info" - <> modifyTableFields tableModification{shippingInfoId = "id" - ,shippingInfoCarrier = "carrier" - ,shippingInfoTrackingNumber = "tracking_number" - } - , shoppingCart3LineItems = +shoppingCart3Db = withDbModification defaultDbSettings $ dbModification + & #shoppingCart3UserAddresses .~ + (setEntityName "addresses" + <> modifyTableFields (tableModification & #addressLine1 .~ "address1" + & #addressLine2 .~ "address2")) + & #shoppingCart3Products .~ + setEntityName "products" + & #shoppingCart3Orders .~ + (setEntityName "orders" + <> modifyTableFields (tableModification & #orderShippingInfo .~ ShippingInfoId "shipping_info__id")) + & #shoppingCart3ShippingInfos .~ + (setEntityName "shipping_info" + <> modifyTableFields (tableModification & #shippingInfoId .~ "id" + & #shippingInfoCarrier .~ "carrier" + & #shippingInfoTrackingNumber .~ "tracking_number")) + & #shoppingCart3LineItems .~ setEntityName "line_items" - } -{------------------------------------------------------------------------------- - Lenses --------------------------------------------------------------------------------} - -lensesLineItemT :: LineItemT (Lenses LineItemT f) -lensesProductT :: ProductT (Lenses ProductT f) -lensesOrderT :: OrderT (Lenses OrderT f) - -lensesLineItemT = tableLenses -lensesProductT = tableLenses -lensesOrderT = tableLenses - -lensesShoppingCart3 :: ShoppingCart3Db (TableLens f ShoppingCart3Db) -lensesShoppingCart3 = dbLenses - - -xlineItemInOrder :: Lens' (LineItemT f) (C f Int32) -xlineItemInOrder = case lensesLineItemT.lineItemInOrder of OrderId (LensFor l) -> l - -xlineItemForProduct :: Lens' (LineItemT f) (C f Int32) -xlineItemForProduct = case lensesLineItemT.lineItemForProduct of ProductId (LensFor l) -> l - -xlineItemQuantity :: Lens' (LineItemT f) (C f Int32) -xlineItemQuantity = case lensesLineItemT.lineItemQuantity of LensFor l -> l - - -xproductId :: Lens' (ProductT f) (C f Int32) -xproductId = case lensesProductT.productId of LensFor l -> l - -xproductTitle :: Lens' (ProductT f) (C f Text) -xproductTitle = case lensesProductT.productTitle of LensFor l -> l - -xproductDescription :: Lens' (ProductT f) (C f Text) -xproductDescription = case lensesProductT.productDescription of LensFor l -> l - -xproductPrice :: Lens' (ProductT f) (C f Int32) -xproductPrice = case lensesProductT.productPrice of LensFor l -> l - - -xorderId :: Lens' (OrderT f) (C f Int32) -xorderId = case lensesOrderT.orderId of LensFor l -> l - -xorderDate :: Lens' (OrderT f) (C f LocalTime) -xorderDate = case lensesOrderT.orderDate of LensFor l -> l - -xorderForUser :: Lens' (OrderT f) (C f Text) -xorderForUser = case lensesOrderT.orderForUser of UserId (LensFor l) -> l - -xorderShipToAddress :: Lens' (OrderT f) (C f Int32) -xorderShipToAddress = case lensesOrderT.orderShipToAddress of AddressId (LensFor l) -> l - -xorderShippingInfo :: Lens' (OrderT f) (C f (Maybe Int32)) -xorderShippingInfo = case lensesOrderT.orderShippingInfo of ShippingInfoId (LensFor l) -> l - - -xshoppingCart3Users :: Lens' (ShoppingCart3Db f) (f (TableEntity UserT)) -xshoppingCart3Users = case lensesShoppingCart3.shoppingCart3Users of TableLens x -> x - -xshoppingCart3UserAddresses :: Lens' (ShoppingCart3Db f) (f (TableEntity AddressT)) -xshoppingCart3UserAddresses = case lensesShoppingCart3.shoppingCart3UserAddresses of TableLens x -> x - -xshoppingCart3Products :: Lens' (ShoppingCart3Db f) (f (TableEntity ProductT)) -xshoppingCart3Products = case lensesShoppingCart3.shoppingCart3Products of TableLens x -> x - -xshoppingCart3Orders :: Lens' (ShoppingCart3Db f) (f (TableEntity OrderT)) -xshoppingCart3Orders = case lensesShoppingCart3.shoppingCart3Orders of TableLens x -> x - -xshoppingCart3ShippingInfos :: Lens' (ShoppingCart3Db f) (f (TableEntity ShippingInfoT)) -xshoppingCart3ShippingInfos = case lensesShoppingCart3.shoppingCart3ShippingInfos of TableLens x -> x - -xshoppingCart3LineItems :: Lens' (ShoppingCart3Db f) (f (TableEntity LineItemT)) -xshoppingCart3LineItems = case lensesShoppingCart3.shoppingCart3LineItems of TableLens x -> x - --- | Lens from 'Order' to the primary key of the shipping info --- --- Note that nullability translates to 'Maybe'. +--- | Lens from 'Order' to the primary key of the shipping info +--- +--- Note that nullability translates to 'Maybe'. shippingInfo :: Lens' Order (Maybe Int32) -shippingInfo = xorderShippingInfo +shippingInfo = #orderShippingInfo % coerced {------------------------------------------------------------------------------- Tests proper @@ -330,17 +255,17 @@ "CREATE TABLE line_items (item_in_order__id INTEGER NOT NULL, item_for_product__id INTEGER NOT NULL, item_quantity INTEGER NOT NULL)" (jamesAddress1, bettyAddress1, _bettyAddress2, redBall, mathTextbook, introToHaskell, _suitcase) <- do - runInsert $ insert (shoppingCart3Db ^. xshoppingCart3Users) $ + runInsert $ insert (shoppingCart3Db ^. #shoppingCart3Users) $ insertValues users [jamesAddress1, bettyAddress1, bettyAddress2] <- runInsertReturningList $ - insertReturning (shoppingCart3Db ^. xshoppingCart3UserAddresses) $ + insertReturning (shoppingCart3Db ^. #shoppingCart3UserAddresses) $ insertExpressions addresses [redBall, mathTextbook, introToHaskell, suitcase] <- runInsertReturningList $ - insertReturning (shoppingCart3Db ^. xshoppingCart3Products) $ + insertReturning (shoppingCart3Db ^. #shoppingCart3Products) $ insertExpressions products pure ( jamesAddress1, bettyAddress1, bettyAddress2, redBall, mathTextbook, introToHaskell, suitcase ) @@ -352,7 +277,7 @@ bettyShippingInfo <- do [bettyShippingInfo] <- runInsertReturningList $ - insertReturning (shoppingCart3Db ^. xshoppingCart3ShippingInfos) $ + insertReturning (shoppingCart3Db ^. #shoppingCart3ShippingInfos) $ insertExpressions [ ShippingInfo default_ (val_ USPS) (val_ "12345790ABCDEFGHI") ] @@ -363,7 +288,7 @@ now <- liftIO $ zonedTimeToLocalTime <$> getZonedTime [jamesOrder1, bettyOrder1, jamesOrder2] <- runInsertReturningList $ - insertReturning (shoppingCart3Db ^. xshoppingCart3Orders) $ + insertReturning (shoppingCart3Db ^. #shoppingCart3Orders) $ insertExpressions [ Order default_ currentTimestamp_ (val_ (pk james)) (val_ (pk jamesAddress1)) nothing_ , Order default_ currentTimestamp_ (val_ (pk betty)) (val_ (pk bettyAddress1)) (just_ (val_ (pk bettyShippingInfo))) @@ -372,7 +297,7 @@ -- Less than one second should have passed in between us taking a timestamp -- and sqlite actually creating the row liftIO $ assertBool "timestamp" $ - nominalDiffTimeToSeconds ((jamesOrder1 ^. xorderDate) `diffLocalTime` now) < 1 + nominalDiffTimeToSeconds ((jamesOrder1 ^. #orderDate) `diffLocalTime` now) < 1 -- Create line items let lineItems :: [LineItem] @@ -384,15 +309,15 @@ , LineItem (pk bettyOrder1) (pk introToHaskell) 3 , LineItem (pk jamesOrder2) (pk mathTextbook) 1 ] - runInsert $ insert (shoppingCart3Db ^. xshoppingCart3LineItems) $ + runInsert $ insert (shoppingCart3Db ^. #shoppingCart3LineItems) $ insertValues lineItems -- LEFT JOIN: Users and orders usersAndOrders <- runSelectReturningList $ select $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) (\order -> (order ^. #orderForUser) `references_` user) pure (user, order) let expectedUsersAndOrders :: [(User, Maybe Order)] @@ -409,8 +334,8 @@ usersWithNoOrders <- runSelectReturningList $ select $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) (\order -> (order ^. #orderForUser) `references_` user) guard_ (isNothing_ order) pure user liftIO $ assertEqual "usersWithNoOrders" [sam] usersWithNoOrders @@ -419,8 +344,8 @@ usersWithNoOrders' <- runSelectReturningList $ select $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - guard_ (not_ (exists_ (filter_ (\order -> order.orderForUser `references_` user) (all_ (shoppingCart3Db ^. xshoppingCart3Orders))))) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + guard_ (not_ (exists_ (filter_ (\order -> (order ^. #orderForUser) `references_` user) (all_ (shoppingCart3Db ^. #shoppingCart3Orders))))) pure user liftIO $ assertEqual "usersWithNoOrders'" [sam] usersWithNoOrders' @@ -430,20 +355,20 @@ runSelectReturningList $ select $ orderBy_ (\(_order, total) -> desc_ total) $ aggregate_ (\(order, lineItem, product) -> - (group_ order, sum_ (lineItem ^. xlineItemQuantity * product ^. xproductPrice))) + (group_ order, sum_ (lineItem ^. #lineItemQuantity * product ^. #productPrice))) $ do - lineItem <- all_ (shoppingCart3Db ^. xshoppingCart3LineItems) - order <- related_ (shoppingCart3Db ^. xshoppingCart3Orders) lineItem.lineItemInOrder - product <- related_ (shoppingCart3Db ^. xshoppingCart3Products) lineItem.lineItemForProduct + lineItem <- all_ (shoppingCart3Db ^. #shoppingCart3LineItems) + order <- related_ (shoppingCart3Db ^. #shoppingCart3Orders) (lineItem ^. #lineItemInOrder) + product <- related_ (shoppingCart3Db ^. #shoppingCart3Products) (lineItem ^. #lineItemForProduct) pure (order, lineItem, product) let totalJamesOrder1, totalJamesOrder2, totalBettyOrder1 :: Int32 - totalJamesOrder1 = 10 * redBall.productPrice - + 1 * mathTextbook.productPrice - + 4 * introToHaskell.productPrice - totalJamesOrder2 = 1 * mathTextbook.productPrice - totalBettyOrder1 = 3 * mathTextbook.productPrice - + 3 * introToHaskell.productPrice + totalJamesOrder1 = 10 * (redBall ^. #productPrice) + + 1 * (mathTextbook ^. #productPrice) + + 4 * (introToHaskell ^. #productPrice) + totalJamesOrder2 = 1 * (mathTextbook ^. #productPrice) + totalBettyOrder1 = 3 * (mathTextbook ^. #productPrice) + + 3 * (introToHaskell ^. #productPrice) expectedOrdersWithCostOrdered :: [(Order, Maybe Int32)] expectedOrdersWithCostOrdered = [ @@ -459,15 +384,15 @@ runSelectReturningList $ select $ orderBy_ (\(_user, total) -> desc_ total) $ aggregate_ (\(user, lineItem, product) -> - (group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice)))) + (group_ user, sum_ (maybe_ 0 id (lineItem ^. #lineItemQuantity) * maybe_ 0 id (product ^. #productPrice)))) $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user) - lineItem <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3LineItems)) - (\lineItem -> maybe_ (val_ False) (\order' -> lineItem.lineItemInOrder `references_` order') order) - product <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Products)) - (\product -> maybe_ (val_ False) (\lineItem' -> lineItem'.lineItemForProduct `references_` product) lineItem) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user) + lineItem <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3LineItems)) + (\lineItem -> maybe_ (val_ False) (\order' -> (lineItem ^. #lineItemInOrder) `references_` order') order) + product <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Products)) + (\product -> maybe_ (val_ False) (\lineItem' -> (lineItem' ^. #lineItemForProduct) `references_` product) lineItem) pure (user, lineItem, product) -- Bug in beam? Original tutorial (without LR) has same problem. @@ -486,15 +411,15 @@ runSelectReturningList $ select $ orderBy_ (\(_user, total) -> desc_ total) $ aggregate_ (\(user, lineItem, product) -> - (group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice)))) + (group_ user, sum_ (maybe_ 0 id (lineItem ^. #lineItemQuantity) * maybe_ 0 id (product ^. #productPrice)))) $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user) - lineItem <- leftJoin_' (all_ (shoppingCart3Db ^. xshoppingCart3LineItems)) - (\lineItem -> just_ lineItem.lineItemInOrder ==?. pk order) - product <- leftJoin_' (all_ (shoppingCart3Db ^. xshoppingCart3Products)) - (\product -> lineItem.lineItemForProduct ==?. just_ (pk product)) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user) + lineItem <- leftJoin_' (all_ (shoppingCart3Db ^. #shoppingCart3LineItems)) + (\lineItem -> just_ (lineItem ^. #lineItemInOrder) ==?. pk order) + product <- leftJoin_' (all_ (shoppingCart3Db ^. #shoppingCart3Products)) + (\product -> (lineItem ^. #lineItemForProduct) ==?. just_ (pk product)) pure (user, lineItem, product) let expectedAllUsersAndTotals2 :: [(User, Maybe Int32)] @@ -509,8 +434,8 @@ -- Dealing with nullable foreign keys allUnshippedOrders <- runSelectReturningList $ - select $ filter_ (\info -> isNothing_ info.orderShippingInfo) - $ all_ (shoppingCart3Db ^. xshoppingCart3Orders) + select $ filter_ (\info -> isNothing_ (info ^. #orderShippingInfo)) + $ all_ (shoppingCart3Db ^. #shoppingCart3Orders) let expectedAllUnshippedOrders :: [Order] expectedAllUnshippedOrders = [jamesOrder1, jamesOrder2] @@ -521,15 +446,15 @@ shippingInformationByUser <- runSelectReturningList $ select $ aggregate_ (\(user, order) -> - let ShippingInfoId siId = order.orderShippingInfo + let ShippingInfoId siId = order ^. #orderShippingInfo in ( group_ user , as_ @Int32 $ count_ (as_ @(Maybe Int32) (maybe_ (just_ 1) (\_ -> nothing_) siId)) , as_ @Int32 $ count_ siId )) $ do - user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user) + user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) (\order -> (order ^. #orderForUser) `references_` user) pure (user, order) let expectedShippingInformationByUser :: [(User, Int32, Int32)] @@ -548,22 +473,22 @@ shippingInformationByUser' <- runSelectReturningList $ select $ do - forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users) + forUser <- all_ (shoppingCart3Db ^. #shoppingCart3Users) (email, unshippedCount) <- aggregate_ (\(email, _order) -> (group_ email, countAll_)) $ - do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user &&. isNothing_ order.orderShippingInfo) + do user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user &&. isNothing_ (order ^. #orderShippingInfo)) pure (pk user, order) guard_ (email `references_` forUser) (email', shippedCount) <- aggregate_ (\(email', _order) -> (group_ email', countAll_)) $ - do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user &&. isJust_ order.orderShippingInfo) + do user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user &&. isJust_ (order ^. #orderShippingInfo)) pure (pk user, order) guard_ (email' `references_` forUser) @@ -587,14 +512,14 @@ shippingInformationByUser'' <- runSelectReturningList $ select $ - do forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users) + do forUser <- all_ (shoppingCart3Db ^. #shoppingCart3Users) (email, unshippedCount) <- subselect_ $ aggregate_ (\(email, _order) -> (group_ email, countAll_)) $ - do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user &&. isNothing_ order.orderShippingInfo) + do user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user &&. isNothing_ (order ^. #orderShippingInfo)) pure (pk user, order) guard_ (email `references_` forUser) @@ -602,9 +527,9 @@ (email', shippedCount) <- subselect_ $ aggregate_ (\(email', _order) -> (group_ email', countAll_)) $ - do user <- all_ (shoppingCart3Db ^. xshoppingCart3Users) - order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) - (\order -> order.orderForUser `references_` user &&. isJust_ order.orderShippingInfo) + do user <- all_ (shoppingCart3Db ^. #shoppingCart3Users) + order <- leftJoin_ (all_ (shoppingCart3Db ^. #shoppingCart3Orders)) + (\order -> (order ^. #orderForUser) `references_` user &&. isJust_ (order ^. #orderShippingInfo)) pure (pk user, order) guard_ (email' `references_` forUser) @@ -642,12 +567,4 @@ info1 :: ShippingInfo info1 = ShippingInfo 1 USPS "12345790ABCDEFGHI" - - - - - - - - diff --git a/test/Test/Record/Beam/Util/Compat.hs b/test/Test/Record/Beam/Util/Compat.hs --- a/test/Test/Record/Beam/Util/Compat.hs +++ b/test/Test/Record/Beam/Util/Compat.hs diff --git a/test/Test/Record/Beam/Zipping.hs b/test/Test/Record/Beam/Zipping.hs --- a/test/Test/Record/Beam/Zipping.hs +++ b/test/Test/Record/Beam/Zipping.hs @@ -14,8 +14,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Beam.Zipping (tests) where @@ -25,6 +26,7 @@ import Database.Beam.Schema.Tables import Test.Tasty import Test.Tasty.HUnit +import Optics.Core ((^.)) import qualified GHC.Generics as GHC @@ -47,11 +49,11 @@ deriving anyclass (Beamable) instance Table TableA where - data PrimaryKey TableA f = PrimA (Columnar f Int) + newtype PrimaryKey TableA f = PrimA (Columnar f Int) deriving stock (GHC.Generic) deriving anyclass (Beamable) - primaryKey ta = ta.taPrim + primaryKey ta = ta ^. #taPrim deriving instance Show (Columnar f Int) => Show (PrimaryKey TableA f) deriving instance Eq (Columnar f Int) => Eq (PrimaryKey TableA f) diff --git a/test/TestBeamLargeRecords.hs b/test/TestBeamLargeRecords.hs --- a/test/TestBeamLargeRecords.hs +++ b/test/TestBeamLargeRecords.hs