beam-large-records 0.1.2 → 0.1.3
raw patch · 12 files changed
+166/−295 lines, 12 filesdep +optics-coredep ~basedep ~microlensPVP ok
version bump matches the API change (PVP)
Dependencies added: optics-core
Dependency ranges changed: base, microlens
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- beam-large-records.cabal +6/−3
- src/Data/Record/Beam/FromBackendRow.hs +1/−1
- src/Data/Record/Beam/Lenses.hs +0/−0
- src/Data/Record/Beam/ZipTables.hs +0/−1
- test/Test/Record/Beam/SimpleSQL.hs +6/−4
- test/Test/Record/Beam/Tutorial1.hs +15/−13
- test/Test/Record/Beam/Tutorial2.hs +41/−99
- test/Test/Record/Beam/Tutorial3.hs +88/−171
- test/Test/Record/Beam/Util/Compat.hs +0/−0
- test/Test/Record/Beam/Zipping.hs +5/−3
- test/TestBeamLargeRecords.hs +0/−0
CHANGELOG.md view
@@ -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)
beam-large-records.cabal view
@@ -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
src/Data/Record/Beam/FromBackendRow.hs view
@@ -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)
src/Data/Record/Beam/Lenses.hs view
src/Data/Record/Beam/ZipTables.hs view
@@ -68,4 +68,3 @@ instance Beamable table => ZipBeamFieldsI (table (Nullable Uninterpreted)) where zipBeamFieldsI f = liftInterpretedA2 $ zipBeamFieldsM (liftNullableA2 f) -
test/Test/Record/Beam/SimpleSQL.hs view
@@ -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]
test/Test/Record/Beam/Tutorial1.hs view
@@ -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 {
test/Test/Record/Beam/Tutorial2.hs view
@@ -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
test/Test/Record/Beam/Tutorial3.hs view
@@ -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"--------
test/Test/Record/Beam/Util/Compat.hs view
test/Test/Record/Beam/Zipping.hs view
@@ -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)
test/TestBeamLargeRecords.hs view