beam-large-records (empty) → 0.1.1
raw patch · 22 files changed
+2682/−0 lines, 22 filesdep +basedep +beam-coredep +beam-large-records
Dependencies added: base, beam-core, beam-large-records, beam-sqlite, ghc-prim, large-generics, large-records, microlens, record-dot-preprocessor, record-hasfield, sop-core, sqlite-simple, tasty, tasty-hunit, text, time
Files
- CHANGELOG.md +6/−0
- beam-large-records.cabal +96/−0
- src/Data/Record/Beam.hs +12/−0
- src/Data/Record/Beam/Constraints.hs +59/−0
- src/Data/Record/Beam/DbSettings.hs +111/−0
- src/Data/Record/Beam/FromBackendRow.hs +99/−0
- src/Data/Record/Beam/Internal.hs +45/−0
- src/Data/Record/Beam/Interpretation.hs +22/−0
- src/Data/Record/Beam/Lenses.hs +150/−0
- src/Data/Record/Beam/Skeleton.hs +62/−0
- src/Data/Record/Beam/ZipDatabase.hs +65/−0
- src/Data/Record/Beam/ZipTables.hs +71/−0
- test/Test/Record/Beam/Andres.hs +337/−0
- test/Test/Record/Beam/SimpleSQL.hs +104/−0
- test/Test/Record/Beam/Tutorial1.hs +209/−0
- test/Test/Record/Beam/Tutorial2.hs +396/−0
- test/Test/Record/Beam/Tutorial3.hs +653/−0
- test/Test/Record/Beam/Util/Compat.hs +15/−0
- test/Test/Record/Beam/Util/Orphans.hs +25/−0
- test/Test/Record/Beam/Util/SQLite.hs +15/−0
- test/Test/Record/Beam/Zipping.hs +110/−0
- test/TestBeamLargeRecords.hs +20/−0
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for beam-large-records++## 0.1.1 -- 2025-03-11++* First released version+ (we previously depended on an unreleased version of `beam-core`)
+ beam-large-records.cabal view
@@ -0,0 +1,96 @@+cabal-version: 2.4+name: beam-large-records+version: 0.1.1+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+ beam database tables or beam databases.+bug-reports: https://github.com/well-typed/beam-large-records/issues+license: BSD-3-Clause+author: Edsko de Vries+maintainer: edsko@well-typed.com+category: Database+extra-doc-files: CHANGELOG.md+tested-with: GHC ==8.10.7+ GHC ==9.2.8+ GHC ==9.4.8+ GHC ==9.6.6++source-repository head+ type: git+ location: https://github.com/well-typed/beam-large-records++library+ exposed-modules:+ Data.Record.Beam+ other-modules:+ Data.Record.Beam.Constraints+ Data.Record.Beam.DbSettings+ Data.Record.Beam.FromBackendRow+ Data.Record.Beam.Lenses+ Data.Record.Beam.Internal+ Data.Record.Beam.Interpretation+ Data.Record.Beam.Skeleton+ Data.Record.Beam.ZipDatabase+ Data.Record.Beam.ZipTables+ build-depends:+ -- lower bound on beam-core is necessary+ -- see https://github.com/haskell-beam/beam/issues/585+ base >= 4.14 && < 4.19+ , beam-core >= 0.10.3.0 && < 0.11+ , large-generics >= 0.2 && < 0.3+ , microlens >= 0.4 && < 0.5+ , sop-core >= 0.5 && < 0.6+ , text >= 1.2 && < 2.1+ hs-source-dirs:+ src+ default-language:+ Haskell2010+ ghc-options:+ -Wall+ -Wredundant-constraints+ -fmax-refinement-hole-fits=0+ -- The proxying from GHC generics to LR generics needs orphans+ -Wno-orphans++test-suite test-beam-large-records+ type:+ exitcode-stdio-1.0+ main-is:+ TestBeamLargeRecords.hs+ other-modules:+ Test.Record.Beam.Andres+ Test.Record.Beam.SimpleSQL+ Test.Record.Beam.Tutorial1+ Test.Record.Beam.Tutorial2+ Test.Record.Beam.Tutorial3+ Test.Record.Beam.Zipping+ Test.Record.Beam.Util.Compat+ Test.Record.Beam.Util.Orphans+ Test.Record.Beam.Util.SQLite+ hs-source-dirs:+ test+ default-language:+ Haskell2010+ other-extensions:+ TemplateHaskell+ build-depends:+ base+ , beam-core+ , beam-large-records+ , beam-sqlite+ , ghc-prim+ , large-generics+ , large-records+ , microlens+ , record-dot-preprocessor+ , record-hasfield+ , sqlite-simple+ , tasty+ , tasty-hunit+ , text+ , time+ ghc-options:+ -Wall+ -Wredundant-constraints+ -fmax-refinement-hole-fits=0
+ src/Data/Record/Beam.hs view
@@ -0,0 +1,12 @@+module Data.Record.Beam (+ module X+ ) where++import Data.Record.Beam.Constraints as X+import Data.Record.Beam.DbSettings as X+import Data.Record.Beam.FromBackendRow as X+import Data.Record.Beam.Lenses as X+import Data.Record.Beam.Skeleton as X+import Data.Record.Beam.ZipDatabase as X+import Data.Record.Beam.ZipTables as X+
+ src/Data/Record/Beam/Constraints.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.Constraints (+ GLargeFieldsFulfillConstraint+ , WithConstrainedFieldsI+ ) where++import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables+import GHC.Generics hiding (Generic(..), (:.:))++import qualified Data.Record.Generic.Rep as Rep++import Data.Record.Beam.Interpretation++type GLargeFieldsFulfillConstraint tbl c = (+ Generic (tbl (HasConstraint c))+ , Generic (tbl Uninterpreted)+ , HasNormalForm (BeamInterpretation (HasConstraint c)) (tbl (HasConstraint c)) (tbl Uninterpreted)+ , Constraints (tbl Uninterpreted) (WithConstrainedFieldsI c)+ )++instance GLargeFieldsFulfillConstraint tbl c+ => GFieldsFulfillConstraint c (ThroughLRGenerics (tbl Exposed))+ (ThroughLRGenerics (tbl (HasConstraint c))) where+ gWithConstrainedFields pc _ = WrapThroughLRGenerics $+ to . denormalize1 (Proxy @BeamInterpretation) $+ Rep.cpure (Proxy @(WithConstrainedFieldsI c)) (withConstrainedFieldsI pc)++class WithConstrainedFieldsI c x where+ withConstrainedFieldsI :: Proxy c -> Interpret (BeamInterpretation (HasConstraint c)) x++instance c x => WithConstrainedFieldsI c (Uninterpreted x) where+ withConstrainedFieldsI pc = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (HasConstraint c x) ()+ fromBeam = gWithConstrainedFields pc (Proxy @(K1 R (Exposed x)))++instance FieldsFulfillConstraint c tbl+ => WithConstrainedFieldsI c (tbl Uninterpreted) where+ withConstrainedFieldsI pc = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (tbl (HasConstraint c)) ()+ fromBeam = gWithConstrainedFields pc (Proxy @(K1 R (tbl Exposed)))++instance FieldsFulfillConstraintNullable c tbl+ => WithConstrainedFieldsI c (tbl (Nullable Uninterpreted)) where+ withConstrainedFieldsI pc = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (tbl (Nullable (HasConstraint c))) ()+ fromBeam = gWithConstrainedFields pc (Proxy @(K1 R (tbl (Nullable Exposed))))
+ src/Data/Record/Beam/DbSettings.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.DbSettings (+ GAutoLargeDbSettings+ , DbSettingsI+ ) where++import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables+import GHC.Generics hiding (Generic(..))++import qualified Data.Record.Generic.Rep as Rep++import Data.Record.Beam.Interpretation++{-------------------------------------------------------------------------------+ DB settings+-------------------------------------------------------------------------------}++type GAutoLargeDbSettings be db = (+ Generic (db Uninterpreted)+ , Generic (db (DatabaseEntity be db))+ , HasNormalForm (DefaultInterpretation (DatabaseEntity be db)) (db (DatabaseEntity be db)) (db Uninterpreted)+ , Constraints (db Uninterpreted) (DbSettingsI be db)+ )++instance GAutoLargeDbSettings be db+ => (GAutoDbSettings (ThroughLRGenerics (db (DatabaseEntity be db)) ())) where+ autoDbSettings' = WrapThroughLRGenerics $+ to . denormalize1 (Proxy @DefaultInterpretation) $+ Rep.cmap+ (Proxy @(DbSettingsI be db))+ dbSettingsI+ (ghcMetadataFields (ghcMetadata (Proxy @(db Uninterpreted))))++class DbSettingsI be db x where+ dbSettingsI ::+ GhcFieldMetadata x+ -> Interpret (DefaultInterpretation (DatabaseEntity be db)) x++instance (IsDatabaseEntity be x, DatabaseEntityDefaultRequirements be x)+ => DbSettingsI be db (Uninterpreted x) where+ dbSettingsI (GhcFieldMetadata p) = Interpret $ unK1 . unM1 $ fromBeam p+ where+ fromBeam ::+ Selector f+ => Proxy f+ -> S1 f (K1 R (DatabaseEntity be db x)) p+ fromBeam _ = autoDbSettings'++{-------------------------------------------------------------------------------+ Table settings+-------------------------------------------------------------------------------}++type GDefaultLargeTableFieldSettings tbl sub = (+ Generic (tbl (TableField sub))+ , Generic (tbl Uninterpreted)+ , HasNormalForm (BeamInterpretation (TableField sub)) (tbl (TableField sub)) (tbl Uninterpreted)+ , Constraints (tbl Uninterpreted) (TableSettingsI sub)+ )++instance GDefaultLargeTableFieldSettings tbl sub+ => GDefaultTableFieldSettings (ThroughLRGenerics (tbl (TableField sub)) ())+ where+ gDefTblFieldSettings _ = WrapThroughLRGenerics $+ to . denormalize1 (Proxy @BeamInterpretation) $+ Rep.cmap+ (Proxy @(TableSettingsI sub))+ tableSettingsI+ (ghcMetadataFields (ghcMetadata (Proxy @(tbl Uninterpreted))))++class TableSettingsI tbl x where+ tableSettingsI ::+ GhcFieldMetadata x+ -> Interpret (BeamInterpretation (TableField tbl)) x++instance TableSettingsI tbl (Uninterpreted x) where+ tableSettingsI (GhcFieldMetadata p) = Interpret $ unK1 . unM1 $ fromBeam p+ where+ fromBeam :: Selector f => Proxy f -> S1 f (K1 R (TableField tbl x)) p+ fromBeam _ = gDefTblFieldSettings Proxy++instance ( ChooseSubTableStrategy tbl sub ~ strategy+ , SubTableStrategyImpl strategy (TableField tbl) sub+ , Beamable sub+ ) => TableSettingsI tbl (sub Uninterpreted) where+ tableSettingsI (GhcFieldMetadata p) = Interpret $ unK1 . unM1 $ fromBeam p+ where+ fromBeam :: Selector f => Proxy f -> S1 f (K1 R (sub (TableField tbl))) p+ fromBeam _ = gDefTblFieldSettings Proxy++instance ( ChooseSubTableStrategy tbl sub ~ strategy+ , SubTableStrategyImpl strategy (Nullable (TableField tbl)) sub+ , Beamable sub+ ) => TableSettingsI tbl (sub (Nullable Uninterpreted)) where+ tableSettingsI (GhcFieldMetadata p) = Interpret $ unK1 . unM1 $ fromBeam p+ where+ fromBeam :: Selector f => Proxy f -> S1 f (K1 R (sub (Nullable (TableField tbl)))) p+ fromBeam _ = gDefTblFieldSettings Proxy+
+ src/Data/Record/Beam/FromBackendRow.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.FromBackendRow (+ GFromLargeBackendRow+ , FromBackendRowI+ ) where++import Data.Functor.Identity+import Data.List (foldl')+import Data.Proxy+import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Backend.SQL.Row+import Database.Beam.Schema.Tables+import GHC.Generics hiding (Generic(..), (:.:))++import qualified Data.Record.Generic.Rep as Rep++import Data.Record.Beam.Interpretation++type GFromLargeBackendRow be tbl = (+ Generic (tbl Identity)+ , Generic (tbl Uninterpreted)+ , HasNormalForm (BeamInterpretation Identity) (tbl Identity) (tbl Uninterpreted)+ , Constraints (tbl Uninterpreted) (FromBackendRowI be)+ )++instance GFromLargeBackendRow be tbl+ => GFromBackendRow be (ThroughLRGenerics (tbl Exposed))+ (ThroughLRGenerics (tbl Identity)) where+ gFromBackendRow _ =+ fmap (WrapThroughLRGenerics . to . denormalize1 (Proxy @BeamInterpretation)) $+ Rep.sequenceA perField+ where+ perField :: Rep (FromBackendRowM be :.: Interpret (BeamInterpretation Identity)) (tbl Uninterpreted)+ perField = Rep.cpure (Proxy @(FromBackendRowI be)) (Comp fromBackendRowI)++ gValuesNeeded pBackend _ _ =+ foldl' (+) 0 $ Rep.collapse perField+ where+ perField :: Rep (K Int) (tbl Uninterpreted)+ perField = Rep.cpure (Proxy @(FromBackendRowI be)) (valuesNeededI pBackend)++{-------------------------------------------------------------------------------+ Internal++ NOTE: the superclass constraints on the 'FromBackendRowI' instances match+ instance heads in beam, but his is what is used in the definition of+ 'GFromBackendRow' itself, so we stick with it (and use @MonoLocalBinds@).+-------------------------------------------------------------------------------}++class FromBackendRowI be x where+ fromBackendRowI :: FromBackendRowM be (Interpret (BeamInterpretation Identity) x)+ valuesNeededI :: Proxy be -> K Int x++instance FromBackendRow be x => FromBackendRowI be (Uninterpreted x) where+ fromBackendRowI = Interpret . unK1 <$> fromBeam+ where+ fromBeam :: FromBackendRowM be (K1 R x ())+ fromBeam = gFromBackendRow (Proxy @(K1 R (Exposed x)))++ valuesNeededI pBackend = K $+ gValuesNeeded+ pBackend+ (Proxy @(K1 R (Exposed x)))+ (Proxy @((K1 R x)))++instance FromBackendRow be (tbl Identity) => FromBackendRowI be (tbl Uninterpreted) where+ fromBackendRowI = Interpret . unK1 <$> fromBeam+ where+ fromBeam :: FromBackendRowM be (K1 R (tbl Identity) ())+ fromBeam = gFromBackendRow (Proxy @(K1 R (tbl Exposed)))++ valuesNeededI pBackend = K $+ gValuesNeeded+ pBackend+ (Proxy @(K1 R (tbl Exposed)))+ (Proxy @(K1 R (tbl Identity)))++instance FromBackendRow be (tbl (Nullable Identity))+ => FromBackendRowI be (tbl (Nullable Uninterpreted)) where+ fromBackendRowI = Interpret . unK1 <$> fromBeam+ where+ fromBeam :: FromBackendRowM be (K1 R (tbl (Nullable Identity)) ())+ fromBeam = gFromBackendRow (Proxy @(K1 R (tbl (Nullable Exposed))))++ valuesNeededI pBackend = K $+ gValuesNeeded+ pBackend+ (Proxy @(K1 R (tbl (Nullable Exposed))))+ (Proxy @(K1 R (tbl (Nullable Identity))))
+ src/Data/Record/Beam/Internal.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RankNTypes #-}+-- | Utility functions for working with beam+--+-- These are not exported from Data.Record.Beam, and should be considered+-- internal use only.+module Data.Record.Beam.Internal (+ -- * Working with Columnar'+ liftColumnarA2+ , liftNullableA2+ ) where++import Data.Coerce (coerce)+import Data.Proxy+import Database.Beam.Schema.Tables++{-------------------------------------------------------------------------------+ Working with Columnar'+-------------------------------------------------------------------------------}++liftColumnarA2 ::+ Functor m+ => Proxy x+ -> (Columnar' f x -> Columnar' g x -> m (Columnar' h x))+ -> (Columnar f x -> Columnar g x -> m (Columnar h x))+liftColumnarA2 _ f fx gx = getColumnar' <$> f (Columnar' fx) (Columnar' gx)++liftNullableA2 ::+ Functor m+ => (forall x. Columnar' f x -> Columnar' g x -> m (Columnar' h x))+ -> (forall x. Columnar' (Nullable f) x -> Columnar' (Nullable g) x -> m (Columnar' (Nullable h) x))+liftNullableA2 f x y = toNullable <$> f (fromNullable x) (fromNullable y)+ where+ toNullable :: Columnar' w (Maybe a) -> Columnar' (Nullable w) a+ toNullable = coerce++ fromNullable :: Columnar' (Nullable w) a -> Columnar' w (Maybe a)+ fromNullable = coerce++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++getColumnar' :: Columnar' f a -> Columnar f a+getColumnar' (Columnar' x) = x+
+ src/Data/Record/Beam/Interpretation.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Record.Beam.Interpretation (+ BeamInterpretation+ ) where++import Data.Kind+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables++-- | Interpretation domain+--+-- This is (mostly) for internal use; client code will probably not have to+-- interact with this directly.+--+-- See "Data.Record.Generic.Transform" for details on interpretation domains.+data BeamInterpretation (f :: Type -> Type)++type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x+type instance Interpreted (BeamInterpretation f) (table Uninterpreted) = table f+type instance Interpreted (BeamInterpretation f) (table (Nullable Uninterpreted)) = table (Nullable f)
+ src/Data/Record/Beam/Lenses.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.Lenses (+ GLargeTableLenses+ , TableLensesI+ , GLargeDatabaseLenses+ ) where++import Data.Proxy+import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Lens.VL+import Data.Record.Generic.Transform+import Database.Beam.Schema+import Lens.Micro hiding (to)++import qualified Data.Record.Generic.Rep as Rep+import qualified GHC.Generics as GHC++import Data.Record.Beam.Interpretation++{-------------------------------------------------------------------------------+ Table lenses+-------------------------------------------------------------------------------}++type GLargeTableLenses outer tbl f = (+ Generic (tbl (Lenses outer f))+ , Generic (tbl Uninterpreted)+ , Generic (tbl f)+ , HasNormalForm (BeamInterpretation (Lenses outer f)) (tbl (Lenses outer f)) (tbl Uninterpreted)+ , HasNormalForm (BeamInterpretation f) (tbl f) (tbl Uninterpreted)+ , Constraints (tbl Uninterpreted) (TableLensesI outer f)+ )++instance GLargeTableLenses outer tbl f+ => GTableLenses outer f (ThroughLRGenerics (tbl f))+ (ThroughLRGenerics (tbl (Lenses outer f))) where+ gTableLenses ::+ Proxy (ThroughLRGenerics (tbl f))+ -> Lens' (outer f) (ThroughLRGenerics (tbl f) p)+ -> ThroughLRGenerics (tbl (Lenses outer f)) ()+ gTableLenses _ lensToHere = WrapThroughLRGenerics $+ to . denormalize1 (Proxy @BeamInterpretation) $+ Rep.cmap+ (Proxy @(TableLensesI outer f))+ aux+ (lensesForHKRecord (Proxy @BeamInterpretation))+ where+ aux ::+ TableLensesI outer f x+ => HKRecordLens BeamInterpretation f tbl x+ -> Interpret (BeamInterpretation (Lenses outer f)) x+ aux (HKRecordLens l) = tableLensesI $+ lensToHere+ . unwrapThroughLRGenericsLens+ . l+ . interpretedLens++class TableLensesI outer f x where+ tableLensesI ::+ Lens' (outer f) (Interpreted (BeamInterpretation f) x)+ -> Interpret (BeamInterpretation (Lenses outer f)) x++-- GHC.Generic required by 'LensFor' constructor+instance GHC.Generic (outer f) => TableLensesI outer f (Uninterpreted x) where+ tableLensesI lensToHere = Interpret $ LensFor lensToHere++-- We to through the GHC generics instance so that it works both when the+-- subsubtable uses GHC generics (typically, primary keys) and when it uses+-- LR generics (typically, mixins).+instance ( GHC.Generic (sub (Lenses outer f))+ , GHC.Generic (sub f)+ , GTableLenses outer f (GHC.Rep (sub f)) (GHC.Rep (sub (Lenses outer f)))+ )+ => TableLensesI outer f (sub Uninterpreted) where+ tableLensesI lensToHere = Interpret $+ GHC.to $ gTableLenses Proxy (lensToHere . ghcGenericLens)++instance ( GHC.Generic (sub (Nullable (Lenses outer f)))+ , GHC.Generic (sub (Nullable f))+ , GTableLenses outer f (GHC.Rep (sub (Nullable f))) (GHC.Rep (sub (Nullable (Lenses outer f))))+ )+ => TableLensesI outer f (sub (Nullable Uninterpreted)) where+ tableLensesI lensToHere = Interpret $+ GHC.to $ gTableLenses Proxy (lensToHere . ghcGenericLens)++{-------------------------------------------------------------------------------+ DB lenses+-------------------------------------------------------------------------------}++type GLargeDatabaseLenses outer db f = (+ Generic (db (TableLens f outer))+ , Generic (db Uninterpreted)+ , Generic (db f)+ , HasNormalForm (DefaultInterpretation (TableLens f outer)) (db (TableLens f outer)) (db Uninterpreted)+ , HasNormalForm (DefaultInterpretation f) (db f) (db Uninterpreted)+ , Constraints (db Uninterpreted) (DbLensesI outer f)+ )++instance GLargeDatabaseLenses outer db f+ => GDatabaseLenses (outer f) (ThroughLRGenerics (db f))+ (ThroughLRGenerics (db (TableLens f outer))) where+ gDatabaseLenses ::+ Lens' (outer f) (ThroughLRGenerics (db f) p)+ -> ThroughLRGenerics (db (TableLens f outer)) ()+ gDatabaseLenses lensToHere = WrapThroughLRGenerics $+ to . denormalize1 (Proxy @(DefaultInterpretation)) $+ Rep.cmap+ (Proxy @(DbLensesI outer f))+ aux+ (lensesForHKRecord (Proxy @DefaultInterpretation))+ where+ aux ::+ DbLensesI outer f x+ => HKRecordLens DefaultInterpretation f db x+ -> Interpret (DefaultInterpretation (TableLens f outer)) x+ aux (HKRecordLens l) = dbLensesI $+ lensToHere+ . unwrapThroughLRGenericsLens+ . l+ . interpretedLens++class DbLensesI outer f x where+ dbLensesI ::+ Lens' (outer f) (Interpreted (DefaultInterpretation f) x)+ -> Interpret (DefaultInterpretation (TableLens f outer)) x++instance DbLensesI db f (Uninterpreted (TableEntity tbl)) where+ dbLensesI lensToHere = Interpret $ TableLens lensToHere++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++ghcGenericLens :: GHC.Generic a => Lens' a (GHC.Rep a p)+ghcGenericLens f x = GHC.to <$> f (GHC.from x)++unwrapThroughLRGenericsLens :: Lens' (ThroughLRGenerics a p) a+unwrapThroughLRGenericsLens f x =+ WrapThroughLRGenerics <$> f (unwrapThroughLRGenerics x)
+ src/Data/Record/Beam/Skeleton.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Record.Beam.Skeleton (+ GLargeTableSkeleton+ , TblSkeletonI+ ) where++import Data.Proxy+import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables+import GHC.Generics hiding (Generic(..))++import qualified Data.Record.Generic.Rep as Rep++import Data.Record.Beam.Interpretation++type GLargeTableSkeleton tbl = (+ Generic (tbl Ignored)+ , Generic (tbl Uninterpreted)+ , Constraints (tbl Uninterpreted) TblSkeletonI+ , HasNormalForm (BeamInterpretation Ignored) (tbl Ignored) (tbl Uninterpreted)+ )++instance GLargeTableSkeleton tbl+ => GTableSkeleton (ThroughLRGenerics (tbl Ignored)) where+ gTblSkeleton _ =+ WrapThroughLRGenerics . to . denormalize1 (Proxy @BeamInterpretation) $+ Rep.cpure (Proxy @TblSkeletonI) tblSkeletonI++{-------------------------------------------------------------------------------+ Cases for 'gTblSkeleton'++ The 'BeamInterpretation' makes it possible to mirror the case distinction+ that beam is using in the 'GTableSkeleton' instances.+-------------------------------------------------------------------------------}++class TblSkeletonI a where+ tblSkeletonI :: Interpret (BeamInterpretation Ignored) a++instance TblSkeletonI (Uninterpreted x) where+ tblSkeletonI = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (Ignored field) ()+ fromBeam = gTblSkeleton Proxy++instance Beamable tbl => TblSkeletonI (tbl Uninterpreted) where+ tblSkeletonI = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (tbl Ignored) ()+ fromBeam = gTblSkeleton Proxy++instance Beamable tbl => TblSkeletonI (tbl (Nullable Uninterpreted)) where+ tblSkeletonI = Interpret $ unK1 fromBeam+ where+ fromBeam :: K1 R (tbl (Nullable Ignored)) ()+ fromBeam = gTblSkeleton Proxy
+ src/Data/Record/Beam/ZipDatabase.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.ZipDatabase (+ GZipLargeDatabase+ , ZipTablesI+ ) where++import Data.Proxy+import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables++import qualified Data.Record.Generic.Rep as Rep++type GZipLargeDatabase db f g h = (+ Generic (db f)+ , Generic (db g)+ , Generic (db h)+ , Generic (db Uninterpreted)+ , Constraints (db Uninterpreted) ZipTablesI+ , HasNormalForm (DefaultInterpretation f) (db f) (db Uninterpreted)+ , HasNormalForm (DefaultInterpretation g) (db g) (db Uninterpreted)+ , HasNormalForm (DefaultInterpretation h) (db h) (db Uninterpreted)+ )++instance GZipLargeDatabase db f g h+ => GZipDatabase be f g h (ThroughLRGenerics (db f))+ (ThroughLRGenerics (db g))+ (ThroughLRGenerics (db h)) where+ gZipDatabase (_, _, _, pBackend) f x y =+ fmap (WrapThroughLRGenerics . to . denormalize1 (Proxy @DefaultInterpretation)) $+ Rep.czipWithM+ (Proxy @ZipTablesI)+ (zipTablesI pBackend f)+ (normalize1 (Proxy @DefaultInterpretation) (from (unwrapThroughLRGenerics x)))+ (normalize1 (Proxy @DefaultInterpretation) (from (unwrapThroughLRGenerics y)))++{-------------------------------------------------------------------------------+ Internal: cases for 'gzipTables'+-------------------------------------------------------------------------------}++class ZipTablesI a where+ zipTablesI ::+ Applicative m+ => Proxy be+ -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl))+ -> Interpret (DefaultInterpretation f) a+ -> Interpret (DefaultInterpretation g) a+ -> m (Interpret (DefaultInterpretation h) a)++instance Table tbl => ZipTablesI (Uninterpreted (TableEntity tbl)) where+ zipTablesI _ f = liftInterpretedA2 f++instance Beamable tbl => ZipTablesI (Uninterpreted (ViewEntity tbl)) where+ zipTablesI _ f = liftInterpretedA2 f++instance ZipTablesI (Uninterpreted (DomainTypeEntity a)) where+ zipTablesI _ f = liftInterpretedA2 f
+ src/Data/Record/Beam/ZipTables.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Record.Beam.ZipTables (+ GZipLargeTables+ , ZipBeamFieldsI+ ) where++import Data.Kind+import Data.Proxy+import Data.Record.Beam.Internal+import Data.Record.Beam.Interpretation+import Data.Record.Generic+import Data.Record.Generic.GHC+import Data.Record.Generic.Transform+import Database.Beam.Schema.Tables++import qualified Data.Record.Generic.Rep as Rep++type GZipLargeTables table f g h = (+ Generic (table f)+ , Generic (table g)+ , Generic (table h)+ , Generic (table Uninterpreted)+ , Constraints (table Uninterpreted) ZipBeamFieldsI+ , HasNormalForm (BeamInterpretation f) (table f) (table Uninterpreted)+ , HasNormalForm (BeamInterpretation g) (table g) (table Uninterpreted)+ , HasNormalForm (BeamInterpretation h) (table h) (table Uninterpreted)+ )++instance GZipLargeTables table f g h+ => GZipTables f g h exposedRep+ (ThroughLRGenerics (table f))+ (ThroughLRGenerics (table g))+ (ThroughLRGenerics (table h)) where+ gZipTables _ f x y =+ fmap (WrapThroughLRGenerics . to . denormalize1 (Proxy @BeamInterpretation)) $+ Rep.czipWithM+ (Proxy @ZipBeamFieldsI)+ (zipBeamFieldsI f)+ (normalize1 (Proxy @BeamInterpretation) (from (unwrapThroughLRGenerics x)))+ (normalize1 (Proxy @BeamInterpretation) (from (unwrapThroughLRGenerics y)))++{-------------------------------------------------------------------------------+ Cases for 'gZipTables'+-------------------------------------------------------------------------------}++class ZipBeamFieldsI (a :: Type) where+ zipBeamFieldsI ::+ Applicative m+ => (forall x. Columnar' f x -> Columnar' g x -> m (Columnar' h x))+ -> Interpret (BeamInterpretation f) a+ -> Interpret (BeamInterpretation g) a+ -> m (Interpret (BeamInterpretation h) a)++instance ZipBeamFieldsI (Uninterpreted x) where+ zipBeamFieldsI f = liftInterpretedA2 $ liftColumnarA2 (Proxy @x) f++instance Beamable table => ZipBeamFieldsI (table Uninterpreted) where+ zipBeamFieldsI f = liftInterpretedA2 $ zipBeamFieldsM f++instance Beamable table => ZipBeamFieldsI (table (Nullable Uninterpreted)) where+ zipBeamFieldsI f = liftInterpretedA2 $ zipBeamFieldsM (liftNullableA2 f)++
+ test/Test/Record/Beam/Andres.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++-- Lots of fields defined here are never used directly+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- | Test cases in Andres' original sketch for this library+module Test.Record.Beam.Andres (tests) where++import Control.Applicative+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Database.Beam+import Database.Beam.Schema.Tables+import GHC.Records.Compat++import qualified Data.List.NonEmpty as NE+import qualified GHC.Generics as GHC++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Beam ()++import Test.Record.Beam.Util.Orphans ()++{-------------------------------------------------------------------------------+ Table A+-------------------------------------------------------------------------------}++{-# ANN type LRTableA largeRecord #-}+data LRTableA (f :: Type -> Type) = MkLRTableA {+ fldA1 :: Columnar f Int+ , fldA2 :: Columnar f Int+ }+ deriving stock (Eq, Show)+ deriving anyclass (Beamable)++instance Table LRTableA where+ newtype PrimaryKey LRTableA f = LRTableAKey (Columnar f Int)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey = LRTableAKey . getField @"fldA1"++deriving instance Show (Columnar f Int) => Show (PrimaryKey LRTableA f)+deriving instance Eq (Columnar f Int) => Eq (PrimaryKey LRTableA f)++{-------------------------------------------------------------------------------+ Table B: has mixin (reference to table A), as well as nullable fields+-------------------------------------------------------------------------------}++{-# ANN type LRTableB largeRecord #-}+data LRTableB (f :: Type -> Type) = MkLRTableB {+ fldB1 :: Columnar f Int+ , fldB2 :: Columnar f Int+ , fldB3 :: Columnar f Bool+ , fldB4 :: Columnar (Nullable f) Char+ , fldB5 :: Columnar f Int+ , fldB6 :: Columnar f String+ , fldB7 :: LRTableA f+ , fldB8 :: PrimaryKey LRTableA f+ , fldB9 :: PrimaryKey LRTableA (Nullable f)+ }+ deriving stock (Eq, Show)+ deriving anyclass (Beamable)++instance Table LRTableB where+ data PrimaryKey LRTableB f = LRTableBKey (Columnar f Int)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey = LRTableBKey . getField @"fldB1"++{-------------------------------------------------------------------------------+ The database definition+-------------------------------------------------------------------------------}++-- | Example of a domain type+--+-- <https://haskell-beam.github.io/beam/user-guide/databases/#domain-types>+newtype EvenInt = EvenInt Int++{-# ANN type LRDB largeRecord #-}+data LRDB (f :: Type -> Type) = MkLRDB {+ tblA :: f (TableEntity LRTableA)+ , tblB :: f (TableEntity LRTableB)+ , viewA :: f (ViewEntity LRTableA)+ , domTyp :: f (DomainTypeEntity EvenInt)+ }+ deriving (Show, Eq)++instance Database be LRDB++exDbSettings :: DatabaseSettings be LRDB+exDbSettings = defaultDbSettings++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Beam.Andres" [+ testCase "zipBeamFields" test_zipBeamFields+ , testCase "tblSkeleton" test_tblSkeleton+ , testCase "zipTables" test_zipTables+ , testCase "autoDbSettings" test_autoDbSettings+ , testCase "withConstraints" test_withConstraints+ ]++test_zipBeamFields :: Assertion+test_zipBeamFields =+ assertEqual "" (runIdentity (zipBeamFieldsM alt ex1 ex2)) exRes+ where+ alt :: forall a.+ Columnar' Maybe a+ -> Columnar' Maybe a+ -> Identity (Columnar' Maybe a)+ alt (Columnar' x) (Columnar' y) = Identity (Columnar' (x <|> y))++ ex1 :: LRTableB Maybe+ ex1 = MkLRTableB {+ fldB1 = Just 2+ , fldB2 = Just 2+ , fldB3 = Nothing+ , fldB4 = Just (Just 'x')+ , fldB5 = Just 4+ , fldB6 = Nothing+ , fldB7 = MkLRTableA {+ fldA1 = Just 8+ , fldA2 = Nothing+ }+ , fldB8 = LRTableAKey (Just 11)+ , fldB9 = LRTableAKey Nothing+ }++ ex2 :: LRTableB Maybe+ ex2 = MkLRTableB {+ fldB1 = Nothing+ , fldB2 = Just 3+ , fldB3 = Nothing+ , fldB4 = Nothing+ , fldB5 = Nothing+ , fldB6 = Just "foo"+ , fldB7 = MkLRTableA {+ fldA1 = Nothing+ , fldA2 = Just 9+ }+ , fldB8 = LRTableAKey (Just 22)+ , fldB9 = LRTableAKey (Just Nothing)+ }++ exRes :: LRTableB Maybe+ exRes = MkLRTableB {+ fldB1 = Just 2+ , fldB2 = Just 2+ , fldB3 = Nothing+ , fldB4 = Just (Just 'x')+ , fldB5 = Just 4+ , fldB6 = Just "foo"+ , fldB7 = MkLRTableA {+ fldA1 = Just 8+ , fldA2 = Just 9+ }+ , fldB8 = LRTableAKey (Just 11)+ -- Outermost Maybe is our choice of @f@, innermost due to 'Nullable'+ , fldB9 = LRTableAKey (Just Nothing)+ }++test_tblSkeleton :: Assertion+test_tblSkeleton = do+ assertEqual "" tblSkeleton ex+ where+ ex :: TableSkeleton LRTableB+ ex = MkLRTableB {+ fldB1 = Ignored+ , fldB2 = Ignored+ , fldB3 = Ignored+ , fldB4 = Ignored+ , fldB5 = Ignored+ , fldB6 = Ignored+ , fldB7 = MkLRTableA {+ fldA1 = Ignored+ , fldA2 = Ignored+ }+ , fldB8 = LRTableAKey Ignored+ , fldB9 = LRTableAKey Ignored+ }++test_zipTables :: Assertion+test_zipTables = do+ assertEqual "" (runIdentity (zipTables (Proxy @()) f dbX dbY)) dbRes+ where+ f :: Const Int tbl -> Const Int tbl -> Identity (Const Bool tbl)+ f (Const x) (Const y) = Identity $ Const (x > y)++ dbX :: LRDB (Const Int)+ dbX = MkLRDB {+ tblA = Const 10+ , tblB = Const 20+ , viewA = Const 10+ , domTyp = Const 20+ }++ dbY :: LRDB (Const Int)+ dbY = MkLRDB {+ tblA = Const 12+ , tblB = Const 18+ , viewA = Const 12+ , domTyp = Const 18+ }++ dbRes :: LRDB (Const Bool)+ dbRes = MkLRDB {+ tblA = Const False+ , tblB = Const True+ , viewA = Const False+ , domTyp = Const True+ }++test_autoDbSettings :: Assertion+test_autoDbSettings =+ assertEqual "" exDbSettings settings+ where+ settings :: LRDB (DatabaseEntity be db)+ settings = MkLRDB {+ tblA = DatabaseEntity $+ DatabaseTable {+ dbTableSchema = Nothing+ , dbTableOrigName = "tblA"+ , dbTableCurrentName = "a"+ , dbTableSettings = MkLRTableA {+ fldA1 = TableField {_fieldPath = NE.fromList ["fldA1"], _fieldName = "a1"}+ , fldA2 = TableField {_fieldPath = NE.fromList ["fldA2"], _fieldName = "a2"}+ }+ }+ , tblB = DatabaseEntity $+ DatabaseTable {+ dbTableSchema = Nothing+ , dbTableOrigName = "tblB"+ , dbTableCurrentName = "b"+ , dbTableSettings = MkLRTableB {+ fldB1 = TableField {_fieldPath = NE.fromList ["fldB1"], _fieldName = "b1"}+ , fldB2 = TableField {_fieldPath = NE.fromList ["fldB2"], _fieldName = "b2"}+ , fldB3 = TableField {_fieldPath = NE.fromList ["fldB3"], _fieldName = "b3"}+ , fldB4 = TableField {_fieldPath = NE.fromList ["fldB4"], _fieldName = "b4"}+ , fldB5 = TableField {_fieldPath = NE.fromList ["fldB5"], _fieldName = "b5"}+ , fldB6 = TableField {_fieldPath = NE.fromList ["fldB6"], _fieldName = "b6"}+ , fldB7 = MkLRTableA {+ fldA1 = TableField {_fieldPath = NE.fromList ["fldB7", "fldA1"], _fieldName = "b7__a1"}+ , fldA2 = TableField {_fieldPath = NE.fromList ["fldB7", "fldA2"], _fieldName = "b7__a2"}+ }+ , fldB8 = LRTableAKey (TableField {_fieldPath = NE.fromList ["fldB8", "fldA1"], _fieldName = "b8__a1"})+ , fldB9 = LRTableAKey (TableField {_fieldPath = NE.fromList ["fldB9", "fldA1"], _fieldName = "b9__a1"})+ }+ }+ , viewA = DatabaseEntity $+ DatabaseView {+ dbViewSchema = Nothing+ , dbViewOrigName = "viewA"+ , dbViewCurrentName = "a"+ , dbViewSettings = MkLRTableA {+ fldA1 = TableField {_fieldPath = NE.fromList ["fldA1"], _fieldName = "a1"}+ , fldA2 = TableField {_fieldPath = NE.fromList ["fldA2"], _fieldName = "a2"}+ }+ }+ , domTyp = DatabaseEntity $+ DatabaseDomainType Nothing "domTyp"+ }++test_withConstraints :: Assertion+test_withConstraints =+ assertEqual "" (showTable canShowB) res+ where+ canShowB :: LRTableB (WithConstraint Show)+ canShowB = withConstrainedFields ex++ ex :: LRTableB Identity+ ex = MkLRTableB {+ fldB1 = 1+ , fldB2 = 2+ , fldB3 = False+ , fldB4 = Just 'a'+ , fldB5 = 4+ , fldB6 = "b"+ , fldB7 = MkLRTableA {+ fldA1 = 5+ , fldA2 = 6+ }+ , fldB8 = LRTableAKey 7+ , fldB9 = LRTableAKey (Just 8)+ }++ -- Note the use of undefined here! Beam does similar things internally;+ -- large-records has been modified so that this works.+ showTable :: Beamable tbl => tbl (WithConstraint Show) -> tbl (Const String)+ showTable tbl = runIdentity $+ zipBeamFieldsM aux tbl undefined+ where+ aux ::+ Columnar' (WithConstraint Show) a+ -> Columnar' whatever a+ -> Identity (Columnar' (Const String) a)+ aux (Columnar' (WithConstraint x)) _ = Identity $+ Columnar' (Const (show x))++ res :: LRTableB (Const String)+ res = MkLRTableB {+ fldB1 = Const "1"+ , fldB2 = Const "2"+ , fldB3 = Const "False"+ , fldB4 = Const "Just 'a'"+ , fldB5 = Const "4"+ , fldB6 = Const "\"b\""+ , fldB7 = MkLRTableA {fldA1 = Const "5", fldA2 = Const "6"}+ , fldB8 = LRTableAKey (Const "7")+ , fldB9 = LRTableAKey (Const "Just 8")+ }+
+ test/Test/Record/Beam/SimpleSQL.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}++-- | Simple but complete example that does an SQL INSERT and SELECT+module Test.Record.Beam.SimpleSQL (+ tests+ -- * Exported to avoid compiler warnings+ , LargeTable(..)+ , ExampleDb(..)+ ) where++import Data.Int+import Data.Kind+import Data.Text (Text)+import Database.Beam++import qualified Database.SQLite.Simple as SQLite+import qualified GHC.Generics as GHC++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Beam ()++import Test.Record.Beam.Util.SQLite++{-------------------------------------------------------------------------------+ Large record example+-------------------------------------------------------------------------------}++{-# ANN type LargeTable largeRecord #-}+data LargeTable (f :: Type -> Type) = MkLargeTable {+ largeTableId :: Columnar f Int32+ , largeTableField :: Columnar f Text+ }+ deriving stock (Show, Eq)+ deriving anyclass (Beamable)++large1, large2 :: LargeTable Identity+large1 = MkLargeTable 1 "hi"+large2 = MkLargeTable 2 "ho"++instance Table LargeTable where+ newtype PrimaryKey LargeTable f = LargeTableKey (Columnar f Int32)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey tbl = LargeTableKey tbl.largeTableId++{-------------------------------------------------------------------------------+ The full database+-------------------------------------------------------------------------------}++{-# ANN type ExampleDb largeRecord #-}+data ExampleDb (f :: Type -> Type) = MkExampleDb {+ exampleDbLargeTable :: f (TableEntity LargeTable)+ }+ deriving (Show)++instance Database be ExampleDb++exampleDb :: DatabaseSettings be ExampleDb+exampleDb = defaultDbSettings++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Beam.SimpleSQL" [+ testCase "insert_select" test_insert_select+ ]++test_insert_select :: Assertion+test_insert_select = runInMemory $ \conn -> do+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE db_large_table (table_id INT PRIMARY KEY NOT NULL, table_field VARCHAR NOT NULL);"++ runInsert $+ insert exampleDb.exampleDbLargeTable $ insertValues [+ large1+ , large2+ ]++ allLarge <- runSelectReturningList $ select $+ orderBy_ (\x -> asc_ (x.largeTableId)) $ all_ exampleDb.exampleDbLargeTable+ liftIO $ assertEqual "allLarge" allLarge [large1, large2]+
+ test/Test/Record/Beam/Tutorial1.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}++module Test.Record.Beam.Tutorial1 (+ tests++ -- * Exported for the benefit of follow-up tutorials+ , UserT(..)+ , User+ , UserId+ , PrimaryKey(..)+ ) where++import Data.Functor.Identity+import Data.Int+import Data.Kind+import Data.Record.Beam ()+import Data.Text (Text)+import Database.Beam hiding (Generic, countAll_)+import Database.Beam.Schema.Tables++import qualified Data.List.NonEmpty as NE+import qualified Database.SQLite.Simple as SQLite+import qualified GHC.Generics as GHC++import Test.Tasty+import Test.Tasty.HUnit++import Test.Record.Beam.Util.Compat+import Test.Record.Beam.Util.SQLite+import Test.Record.Beam.Util.Orphans ()++{-------------------------------------------------------------------------------+ We replicate the beam tutorial, but using large-records++ See <https://haskell-beam.github.io/beam/>+-------------------------------------------------------------------------------}++{-# ANN type UserT largeRecord #-}+data UserT (f :: Type -> Type) = User {+ userEmail :: Columnar f Text+ , userFirstName :: Columnar f Text+ , userLastName :: Columnar f Text+ , userPassword :: Columnar f Text+ }+ deriving stock (Show, Eq)+ deriving anyclass (Beamable)++type User = UserT Identity+type UserId = PrimaryKey UserT Identity++james, betty, sam :: User+james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"+betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"+sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"++james2, betty2, james3, sam2, sam3 :: User+james2 = User "james@pallo.com" "James" "Pallo" "b4cc344d25a2efe540adbf2678e2304c"+betty2 = User "betty@sims.com" "Betty" "Sims" "82b054bd83ffad9b6cf8bdb98ce3cc2f"+james3 = User "james@oreily.com" "James" "O'Reily" "b4cc344d25a2efe540adbf2678e2304c"+sam2 = User "sam@sophitz.com" "Sam" "Sophitz" "332532dcfaa1cbf61e2a266bd723612c"+sam3 = User "sam@jely.com" "Sam" "Jely" "332532dcfaa1cbf61e2a266bd723612c"++instance Table UserT where+ data PrimaryKey UserT f = UserId (Columnar f Text)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ 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)++{-------------------------------------------------------------------------------+ Example DB+-------------------------------------------------------------------------------}++{-# ANN type ShoppingCartDb largeRecord #-}+data ShoppingCartDb (f :: Type -> Type) = ShoppingCartDb {+ shoppingCartUsers :: f (TableEntity UserT)+ }+ deriving (Show, Eq)++instance Database be ShoppingCartDb++shoppingCartDb :: DatabaseSettings be ShoppingCartDb+shoppingCartDb = defaultDbSettings++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Beam.Tutorial1" [+ testCase "tblSkeleton" test_tutorial1_tblSkeleton+ , testCase "defaultDbSettings" test_tutorial1_defaultDbSettings+ , testCase "insertSelect" test_tutorial1_insertSelect+ , testCase "recordDotSyntax" test_tutorial1_recordDotSyntax+ ]++test_tutorial1_tblSkeleton :: Assertion+test_tutorial1_tblSkeleton =+ assertEqual "" expected (tblSkeleton :: TableSkeleton UserT)+ where+ expected :: TableSkeleton UserT+ expected = User {+ userEmail = Ignored+ , userFirstName = Ignored+ , userLastName = Ignored+ , userPassword = Ignored+ }++test_tutorial1_defaultDbSettings :: Assertion+test_tutorial1_defaultDbSettings =+ assertEqual "" expected shoppingCartDb+ where+ expected :: DatabaseSettings be ShoppingCartDb+ expected = ShoppingCartDb {+ shoppingCartUsers = DatabaseEntity (+ DatabaseTable {+ dbTableSchema = Nothing+ , dbTableOrigName = "shoppingCartUsers"+ , dbTableCurrentName = "cart_users"+ , dbTableSettings = User {+ userEmail = TableField { _fieldPath = NE.fromList ["userEmail"] , _fieldName = "email"}+ , userFirstName = TableField { _fieldPath = NE.fromList ["userFirstName"] , _fieldName = "first_name"}+ , userLastName = TableField { _fieldPath = NE.fromList ["userLastName"] , _fieldName = "last_name"}+ , userPassword = TableField { _fieldPath = NE.fromList ["userPassword"] , _fieldName = "password"}+ }+ }+ )+ }++test_tutorial1_insertSelect :: Assertion+test_tutorial1_insertSelect = runInMemory $ \conn -> do+ 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 [+ james+ , betty+ , sam+ ]++ 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)+ 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++ bounded <- runSelectReturningList (select boundedQuery)+ liftIO $ assertEqual "bounded" [james] bounded++ -- 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)+ Just c <- runSelectReturningOne $ select userCount+ liftIO $ assertEqual "userCount" 3 c++ runInsert $ insert shoppingCartDb.shoppingCartUsers $ insertValues [+ james2+ , betty2+ , james3+ , sam2+ , sam3+ ]+ 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++-- Just a sanity check that RDS is working+-- (NOTE: RDS gets confused by nested multiline comments.)+test_tutorial1_recordDotSyntax :: Assertion+test_tutorial1_recordDotSyntax =+ assertEqual "" "a@b.c" u.userEmail+ where+ u :: User+ u = User {+ userEmail = "a@b.c"+ , userFirstName = "John"+ , userLastName = "Doe"+ , userPassword = "secret"+ }+
+ test/Test/Record/Beam/Tutorial2.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}++{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-}++module Test.Record.Beam.Tutorial2 (+ tests++ -- * Exported for the benefit of follow-up tutorials+ , AddressT(..)+ , Address+ , PrimaryKey(..)+ ) where++import Data.Functor.Const+import Data.Int+import Data.Kind+import Data.Text (Text)+import Database.Beam+import Database.Beam.Schema.Tables+import Lens.Micro++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as Text+import qualified Database.SQLite.Simple as SQLite+import qualified GHC.Generics as GHC++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, assertEqual)++import Test.Record.Beam.Tutorial1 hiding (tests)+import Test.Record.Beam.Util.SQLite++{-------------------------------------------------------------------------------+ New table: with a foreign key+-------------------------------------------------------------------------------}++{-# ANN type AddressT largeRecord #-}+data AddressT (f :: Type -> Type) = Address {+ addressId :: C f Int32+ , addressLine1 :: C f Text+ , addressLine2 :: C f (Maybe Text)+ , addressCity :: C f Text+ , addressState :: C f Text+ , addressZip :: C f Text+ , addressForUser :: PrimaryKey UserT f+ }+ deriving (Show, Eq)+ 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++deriving instance Show (Columnar f Int32) => Show (PrimaryKey AddressT f)+deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey AddressT f)++exampleAddress :: Address+exampleAddress = Address {+ addressId = 1+ , addressLine1 = "street"+ , addressLine2 = Nothing+ , addressCity = "city"+ , addressState = "state"+ , addressZip = "zip"+ , addressForUser = UserId "a@b.c"+ }++{-------------------------------------------------------------------------------+ Version 2 of the DB+-------------------------------------------------------------------------------}++{-# ANN type ShoppingCart2Db largeRecord #-}+data ShoppingCart2Db (f :: Type -> Type) = ShoppingCart2Db {+ shoppingCart2Users :: f (TableEntity UserT)+ , shoppingCart2UserAddresses :: f (TableEntity AddressT)+ }+ deriving (Show, Eq)++instance Database be ShoppingCart2Db++shoppingCart2Db :: forall be. DatabaseSettings be ShoppingCart2Db+shoppingCart2Db = defaultDbSettings `withDbModification`+ 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++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Beam.Tutorial2" [+ testCase "defaultDbSettings" test_tutorial2_defaultDbSettings+ , testCase "tableLenses" test_tableLenses+ , testCase "dbLenses" test_dbLenses+ , testCase "SQL" test_SQL+ ]++test_tutorial2_defaultDbSettings :: Assertion+test_tutorial2_defaultDbSettings =+ assertEqual "" expected shoppingCart2Db+ where+ expected :: DatabaseSettings be ShoppingCart2Db+ expected = ShoppingCart2Db {+ shoppingCart2Users = DatabaseEntity $ DatabaseTable {+ dbTableSchema = Nothing+ , dbTableOrigName = "shoppingCart2Users"+ , dbTableCurrentName = "cart2_users"+ , dbTableSettings = User {+ userEmail = TableField {_fieldPath = NE.fromList ["userEmail"] , _fieldName = "email"}+ , userFirstName = TableField {_fieldPath = NE.fromList ["userFirstName"] , _fieldName = "first_name"}+ , userLastName = TableField {_fieldPath = NE.fromList ["userLastName"] , _fieldName = "last_name"}+ , userPassword = TableField {_fieldPath = NE.fromList ["userPassword"] , _fieldName = "password"}+ }+ }+ , shoppingCart2UserAddresses = DatabaseEntity $ DatabaseTable {+ dbTableSchema = Nothing+ , dbTableOrigName = "shoppingCart2UserAddresses"+ , dbTableCurrentName = "addresses"+ , dbTableSettings = Address {+ addressId = TableField {_fieldPath = NE.fromList ["addressId"] , _fieldName = "id"}+ , addressLine1 = TableField {_fieldPath = NE.fromList ["addressLine1"] , _fieldName = "address1"}+ , addressLine2 = TableField {_fieldPath = NE.fromList ["addressLine2"] , _fieldName = "address2"}+ , addressCity = TableField {_fieldPath = NE.fromList ["addressCity"] , _fieldName = "city"}+ , addressState = TableField {_fieldPath = NE.fromList ["addressState"] , _fieldName = "state"}+ , addressZip = TableField {_fieldPath = NE.fromList ["addressZip"] , _fieldName = "zip"}+ , addressForUser = UserId $ TableField {+ _fieldPath = NE.fromList ["addressForUser", "userEmail"]+ , _fieldName = "for_user__email"+ }++ }+ }+ }++test_tableLenses :: Assertion+test_tableLenses = do+ assertEqual "get" expectedGet $+ exampleAddress ^. xaddressId+ assertEqual "set" expectedSet $+ exampleAddress & xaddressForUserId %~ Text.toUpper+ where+ expectedGet :: Int32+ expectedGet = 1++ expectedSet :: Address+ expectedSet = exampleAddress{addressForUser = UserId "A@B.C"}++test_dbLenses :: Assertion+test_dbLenses = do+ assertEqual "get" expectedGet $+ exampleDb ^. xshoppingCart2Users+ assertEqual "set" expectedSet $+ exampleDb & xshoppingCart2UserAddresses %~ (\(Const n) -> Const (n + 1))+ where+ expectedGet :: Const Int a+ expectedGet = Const 1++ exampleDb, expectedSet :: ShoppingCart2Db (Const Int)+ exampleDb = ShoppingCart2Db {+ shoppingCart2Users = Const 1+ , shoppingCart2UserAddresses = Const 2+ }+ expectedSet = exampleDb{shoppingCart2UserAddresses = Const 3}++test_SQL :: Assertion+test_SQL = runInMemory $ \conn -> do+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE cart2_users (email VARCHAR NOT NULL, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL, password VARCHAR NOT NULL, PRIMARY KEY( email ));"+ 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 $+ insertValues [ james, betty, sam ]+ runInsert $ insert shoppingCart2Db.shoppingCart2UserAddresses $+ insertExpressions addresses++ -- Straight-forward SELECT+ -- (Checks that primary keys have been assigned correctly)+ addressesActual <-+ runSelectReturningList $+ select (all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses))+ liftIO $ assertEqual "addresses"+ addressesExpected+ addressesActual++ -- Simple JOIN+ usersAndRelatedAddressesActual <-+ runSelectReturningList $ select $ do+ user <- all_ (shoppingCart2Db ^. xshoppingCart2Users)+ address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ guard_ (address ^. xaddressForUserId ==. user ^. xuserEmail)+ return (user, address)+ liftIO $ assertEqual "usersAndRelatedAddresses"+ usersAndRelatedAddressesExpected+ usersAndRelatedAddressesActual++ -- Alternative way to write the same JOIN+ usersAndRelatedAddressesUsingReferences <-+ runSelectReturningList $ select $ do+ user <- all_ (shoppingCart2Db ^. xshoppingCart2Users)+ address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ guard_ (address.addressForUser `references_` user)+ pure (user, address)+ liftIO $ assertEqual "usersAndRelatedAddressesUsingReferences"+ usersAndRelatedAddressesExpected+ usersAndRelatedAddressesUsingReferences++ -- Using ON+ usersAndRelatedAddressesUsingRelated <-+ runSelectReturningList $ select $ do+ address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ user <- related_ (shoppingCart2Db ^. xshoppingCart2Users) address.addressForUser+ pure (user, address)+ liftIO $ assertEqual "usersAndRelatedAddressesUsingRelated"+ usersAndRelatedAddressesExpected+ usersAndRelatedAddressesUsingRelated++ -- WHERE on a foreign key+ bettysAddresses <-+ runSelectReturningList $ select $ do+ address <- all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ guard_ (address.addressForUser ==. val_ bettyId)+ pure address+ liftIO $ assertEqual "bettysAddresses"+ [addr2, addr3]+ bettysAddresses++ -- Simple UPDATE+ runUpdate $ save (shoppingCart2Db ^. xshoppingCart2Users) $+ james{userPassword = superSecure}+ [james'] <- runSelectReturningList $+ lookup_ (shoppingCart2Db ^. xshoppingCart2Users) jamesId+ liftIO $ assertEqual "James' new password"+ superSecure+ (james' ^. xuserPassword)++ -- More granular UPDATE+ runUpdate $ update (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ (\address -> mconcat [+ address ^. xaddressCity <-. val_ "Sugarville"+ , address ^. xaddressZip <-. val_ "12345"+ ]+ )+ (\address ->+ address ^. xaddressCity ==. val_ "Sugarland"+ &&. address ^. xaddressState ==. val_ "TX"+ )+ updatedAddresses <- runSelectReturningList $+ select $ all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ liftIO $ assertEqual "updatedAddresses"+ [addr1, addr2, addr3']+ updatedAddresses++ -- DELETE+ runDelete $ delete (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ (\address ->+ address ^. xaddressCity ==. "Houston"+ &&. address.addressForUser `references_` val_ betty+ )+ afterDelete <- runSelectReturningList $+ select $ all_ (shoppingCart2Db ^. xshoppingCart2UserAddresses)+ liftIO $ assertEqual "afterDelete"+ [addr1, addr3']+ afterDelete+ where+ james, betty, sam :: User+ james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"+ betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"+ sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"++ jamesId, bettyId :: UserId+ jamesId = UserId "james@example.com"+ bettyId = UserId "betty@example.com"++ -- The tutorial uses @pk@ directly, rather than @val . pk@.+ -- This is possible if we make @james@ and co polymorphic+ --+ -- > james :: UserT (QExpr Sqlite s)+ --+ -- We can do that (because of a 'IsString' instance for 'QExpr', but then we+ -- get into trouble in @addr1@ and co.+ addresses :: [AddressT (QExpr Sqlite s)]+ addresses = [+ Address default_ (val_ "123 Little Street") (val_ Nothing) (val_ "Boston") (val_ "MA") (val_ "12345") (val_ (pk james))+ , Address default_ (val_ "222 Main Street") (val_ (Just "Ste 1")) (val_ "Houston") (val_ "TX") (val_ "8888") (val_ (pk betty))+ , Address default_ (val_ "9999 Residence Ave") (val_ Nothing) (val_ "Sugarland") (val_ "TX") (val_ "8989") (val_ (pk betty))+ ]++ addr1, addr2, addr3, addr3' :: Address+ addr1 = Address 1 "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)+ addr2 = Address 2 "222 Main Street" (Just "Ste 1") "Houston" "TX" "8888" (pk betty)+ addr3 = Address 3 "9999 Residence Ave" Nothing "Sugarland" "TX" "8989" (pk betty)+ addr3' = Address 3 "9999 Residence Ave" Nothing "Sugarville" "TX" "12345" (pk betty)++ addressesExpected :: [Address]+ addressesExpected = [+ addr1+ , addr2+ , addr3+ ]++ usersAndRelatedAddressesExpected :: [(User, Address)]+ usersAndRelatedAddressesExpected = [+ (james, addr1)+ , (betty, addr2)+ , (betty, addr3)+ ]++ superSecure :: Text+ superSecure = "52a516ca6df436828d9c0d26e31ef704"+
+ test/Test/Record/Beam/Tutorial3.hs view
@@ -0,0 +1,653 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}++-- For lens derivation+-- {-# LANGUAGE ImpredicativeTypes #-}+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-top-binds #-}++module Test.Record.Beam.Tutorial3 (tests) where++import Prelude hiding (product)++import Data.Int+import Data.Kind+import Data.Text (Text)+import Data.Time+import Database.Beam hiding (countAll_)+import Database.Beam.Backend.SQL+import Database.Beam.Sqlite+import Lens.Micro++import qualified Data.Text as T+import qualified Database.SQLite.Simple as SQLite+import qualified GHC.Generics as GHC++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Beam ()++import Test.Record.Beam.Tutorial1 hiding (tests)+import Test.Record.Beam.Tutorial2 hiding (tests)+import Test.Record.Beam.Util.Compat+import Test.Record.Beam.Util.SQLite++{-------------------------------------------------------------------------------+ New table: Product++ This does not introduce a new beam features.+-------------------------------------------------------------------------------}++{-# ANN type ProductT largeRecord #-}+data ProductT (f :: Type -> Type) = Product {+ productId :: C f Int32+ , productTitle :: C f Text+ , productDescription :: C f Text+ , productPrice :: C f Int32 {- Price in cents -}+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++instance Table ProductT where+ data PrimaryKey ProductT f = ProductId (Columnar f Int32)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ 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)++type Product = ProductT Identity++{-------------------------------------------------------------------------------+ New table: Order++ This introduces the use of 'Nullable' (as well as the use of a+ custom datatype for a column).+-------------------------------------------------------------------------------}++data ShippingCarrier = USPS | FedEx | UPS | DHL+ deriving (Show, Read, Eq, Ord, Enum)++instance HasSqlValueSyntax be String => HasSqlValueSyntax be ShippingCarrier where+ sqlValueSyntax = autoSqlValueSyntax++instance FromBackendRow Sqlite ShippingCarrier where+ fromBackendRow = read . T.unpack <$> fromBackendRow++{-# ANN type OrderT largeRecord #-}+data OrderT (f :: Type -> Type) = Order {+ orderId :: Columnar f Int32+ , orderDate :: Columnar f LocalTime+ , orderForUser :: PrimaryKey UserT f+ , orderShipToAddress :: PrimaryKey AddressT f+ , orderShippingInfo :: PrimaryKey ShippingInfoT (Nullable f)+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++{-# ANN type ShippingInfoT largeRecord #-}+data ShippingInfoT (f :: Type -> Type) = ShippingInfo {+ shippingInfoId :: Columnar f Int32+ , shippingInfoCarrier :: Columnar f ShippingCarrier+ , shippingInfoTrackingNumber :: Columnar f Text+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++instance Table OrderT where+ data PrimaryKey OrderT f = OrderId (Columnar f Int32)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey o = OrderId o.orderId++instance Table ShippingInfoT where+ data PrimaryKey ShippingInfoT f = ShippingInfoId (Columnar f Int32)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ 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)++deriving instance Show (Columnar f Int32) => Show (PrimaryKey ShippingInfoT f)+deriving instance Eq (Columnar f Int32) => Eq (PrimaryKey ShippingInfoT f)++type Order = OrderT Identity+type ShippingInfo = ShippingInfoT Identity++{-------------------------------------------------------------------------------+ New table: 'LineItem' (many-to-many relation)+-------------------------------------------------------------------------------}++{-# ANN type LineItemT largeRecord #-}+data LineItemT (f :: Type -> Type) = LineItem {+ lineItemInOrder :: PrimaryKey OrderT f+ , lineItemForProduct :: PrimaryKey ProductT f+ , lineItemQuantity :: Columnar f Int32+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++type LineItem = LineItemT Identity++instance Table LineItemT where+ data PrimaryKey LineItemT f =+ LineItemId (PrimaryKey OrderT f) (PrimaryKey ProductT f)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey l = LineItemId l.lineItemInOrder l.lineItemForProduct++{-------------------------------------------------------------------------------+ Version 3 of the DB+-------------------------------------------------------------------------------}++{-# ANN type ShoppingCart3Db largeRecord #-}+data ShoppingCart3Db (f :: Type -> Type) = ShoppingCart3Db {+ shoppingCart3Users :: f (TableEntity UserT)+ , shoppingCart3UserAddresses :: f (TableEntity AddressT)+ , shoppingCart3Products :: f (TableEntity ProductT)+ , shoppingCart3Orders :: f (TableEntity OrderT)+ , shoppingCart3ShippingInfos :: f (TableEntity ShippingInfoT)+ , shoppingCart3LineItems :: f (TableEntity LineItemT)+ }++instance Database be ShoppingCart3Db++{-------------------------------------------------------------------------------+ DB settings+-------------------------------------------------------------------------------}++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 =+ 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'.+shippingInfo :: Lens' Order (Maybe Int32)+shippingInfo = xorderShippingInfo++{-------------------------------------------------------------------------------+ Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Beam.Tutorial3" [+ testCase "lensToNullableField" test_lensToNullableField+ , testCase "SQL" test_SQL+ ]++test_lensToNullableField :: Assertion+test_lensToNullableField = do+ now <- zonedTimeToLocalTime <$> getZonedTime+ assertEqual "Just" (Just 3) (exampleOrder1 now ^. shippingInfo)+ assertEqual "Nothing" Nothing (exampleOrder2 now ^. shippingInfo)+ assertEqual "set" (exampleOrder1 now) $+ (exampleOrder2 now) & shippingInfo .~ Just 3+ where+ exampleOrder1, exampleOrder2 :: LocalTime -> Order+ exampleOrder1 now = Order {+ orderId = 1+ , orderDate = now+ , orderForUser = UserId "a@b.c"+ , orderShipToAddress = AddressId 1+ , orderShippingInfo = ShippingInfoId (Just 3)+ }+ exampleOrder2 now = Order {+ orderId = 1+ , orderDate = now+ , orderForUser = UserId "a@b.c"+ , orderShipToAddress = AddressId 1+ , orderShippingInfo = ShippingInfoId Nothing+ }++test_SQL :: Assertion+test_SQL = runInMemory $ \conn -> do+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE cart3_users (email VARCHAR NOT NULL, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL, password VARCHAR NOT NULL, PRIMARY KEY( email ));"+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE addresses ( id INTEGER PRIMARY KEY AUTOINCREMENT, address1 VARCHAR NOT NULL, address2 VARCHAR, city VARCHAR NOT NULL, state VARCHAR NOT NULL, zip VARCHAR NOT NULL, for_user__email VARCHAR NOT NULL );"+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE products ( id INTEGER PRIMARY KEY AUTOINCREMENT, title VARCHAR NOT NULL, description VARCHAR NOT NULL, price INT NOT NULL );"+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE orders ( id INTEGER PRIMARY KEY AUTOINCREMENT, date TIMESTAMP NOT NULL, for_user__email VARCHAR NOT NULL, ship_to_address__id INT NOT NULL, shipping_info__id INT);"+ liftIO $ SQLite.execute_ conn $+ "CREATE TABLE shipping_info ( id INTEGER PRIMARY KEY AUTOINCREMENT, carrier VARCHAR NOT NULL, tracking_number VARCHAR NOT NULL);"+ liftIO $ SQLite.execute_ conn $+ "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) $+ insertValues users++ [jamesAddress1, bettyAddress1, bettyAddress2] <-+ runInsertReturningList $+ insertReturning (shoppingCart3Db ^. xshoppingCart3UserAddresses) $+ insertExpressions addresses++ [redBall, mathTextbook, introToHaskell, suitcase] <-+ runInsertReturningList $+ insertReturning (shoppingCart3Db ^. xshoppingCart3Products) $+ insertExpressions products++ pure ( jamesAddress1, bettyAddress1, bettyAddress2, redBall, mathTextbook, introToHaskell, suitcase )++ -- Check autoincrement field+ liftIO $ assertEqual "jamesAddress1" addr1 jamesAddress1++ -- Marshalling custom types+ bettyShippingInfo <- do+ [bettyShippingInfo] <-+ runInsertReturningList $+ insertReturning (shoppingCart3Db ^. xshoppingCart3ShippingInfos) $+ insertExpressions [+ ShippingInfo default_ (val_ USPS) (val_ "12345790ABCDEFGHI")+ ]+ pure bettyShippingInfo+ liftIO $ assertEqual "bettyShippingInfo" info1 bettyShippingInfo++ -- Timestamps+ now <- liftIO $ zonedTimeToLocalTime <$> getZonedTime+ [jamesOrder1, bettyOrder1, jamesOrder2] <-+ runInsertReturningList $+ insertReturning (shoppingCart3Db ^. xshoppingCart3Orders) $+ insertExpressions [+ Order default_ currentTimestamp_ (val_ (pk james)) (val_ (pk jamesAddress1)) nothing_+ , Order default_ currentTimestamp_ (val_ (pk betty)) (val_ (pk bettyAddress1)) (just_ (val_ (pk bettyShippingInfo)))+ , Order default_ currentTimestamp_ (val_ (pk james)) (val_ (pk jamesAddress1)) nothing_+ ]+ -- 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++ -- Create line items+ let lineItems :: [LineItem]+ lineItems = [+ LineItem (pk jamesOrder1) (pk redBall) 10+ , LineItem (pk jamesOrder1) (pk mathTextbook) 1+ , LineItem (pk jamesOrder1) (pk introToHaskell) 4+ , LineItem (pk bettyOrder1) (pk mathTextbook) 3+ , LineItem (pk bettyOrder1) (pk introToHaskell) 3+ , LineItem (pk jamesOrder2) (pk mathTextbook) 1+ ]+ runInsert $ insert (shoppingCart3Db ^. xshoppingCart3LineItems) $+ 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)+ pure (user, order)++ let expectedUsersAndOrders :: [(User, Maybe Order)]+ expectedUsersAndOrders = [+ (james, Just jamesOrder1)+ , (james, Just jamesOrder2)+ , (betty, Just bettyOrder1)+ , (sam, Nothing)+ ]++ liftIO $ assertEqual "usersAndOrders" expectedUsersAndOrders usersAndOrders++ -- LEFT JOIN: Users without any orders+ usersWithNoOrders <-+ runSelectReturningList $+ select $ do+ user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)+ order <- leftJoin_ (all_ (shoppingCart3Db ^. xshoppingCart3Orders)) (\order -> order.orderForUser `references_` user)+ guard_ (isNothing_ order)+ pure user+ liftIO $ assertEqual "usersWithNoOrders" [sam] usersWithNoOrders++ -- Alternative way to get users with no orders+ usersWithNoOrders' <-+ runSelectReturningList $+ select $ do+ user <- all_ (shoppingCart3Db ^. xshoppingCart3Users)+ guard_ (not_ (exists_ (filter_ (\order -> order.orderForUser `references_` user) (all_ (shoppingCart3Db ^. xshoppingCart3Orders)))))+ pure user++ liftIO $ assertEqual "usersWithNoOrders'" [sam] usersWithNoOrders'++ -- Aggregates+ ordersWithCostOrdered <-+ runSelectReturningList $+ select $ orderBy_ (\(_order, total) -> desc_ total)+ $ aggregate_ (\(order, lineItem, product) ->+ (group_ order, sum_ (lineItem ^. xlineItemQuantity * product ^. xproductPrice)))+ $ do+ lineItem <- all_ (shoppingCart3Db ^. xshoppingCart3LineItems)+ order <- related_ (shoppingCart3Db ^. xshoppingCart3Orders) lineItem.lineItemInOrder+ product <- related_ (shoppingCart3Db ^. xshoppingCart3Products) 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++ expectedOrdersWithCostOrdered :: [(Order, Maybe Int32)]+ expectedOrdersWithCostOrdered = [+ (jamesOrder1, Just totalJamesOrder1)+ , (bettyOrder1, Just totalBettyOrder1)+ , (jamesOrder2, Just totalJamesOrder2)+ ]++ liftIO $ assertEqual "ordersWithCostOrdered" expectedOrdersWithCostOrdered ordersWithCostOrdered++ -- LEFT JOIN: Using 'maybe_'+ allUsersAndTotals <-+ runSelectReturningList $+ select $ orderBy_ (\(_user, total) -> desc_ total)+ $ aggregate_ (\(user, lineItem, product) ->+ (group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice))))+ $ 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)+ pure (user, lineItem, product)++ -- Bug in beam? Original tutorial (without LR) has same problem.+ -- <https://github.com/haskell-beam/beam/issues/580>+ let expectedAllUsersAndTotals :: [(User, Maybe Int32)]+ expectedAllUsersAndTotals = [+ (betty, Just totalBettyOrder1)+ , (james, Just 0) -- TODO: Should be (totalJamesOrder1 + totalJamesOrder2))+ , (sam, Just 0)+ ]++ liftIO $ assertEqual "allUsersAndTotals" expectedAllUsersAndTotals allUsersAndTotals++ -- LEFT JOIN: Using 'leftJoin_''+ allUsersAndTotals2 <-+ runSelectReturningList $+ select $ orderBy_ (\(_user, total) -> desc_ total)+ $ aggregate_ (\(user, lineItem, product) ->+ (group_ user, sum_ (maybe_ 0 id lineItem.lineItemQuantity * maybe_ 0 id (product ^. xproductPrice))))+ $ 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))+ pure (user, lineItem, product)++ let expectedAllUsersAndTotals2 :: [(User, Maybe Int32)]+ expectedAllUsersAndTotals2 = [+ (james, Just (totalJamesOrder1 + totalJamesOrder2))+ , (betty, Just totalBettyOrder1)+ , (sam, Just 0)+ ]++ liftIO $ assertEqual "allUsersAndTotals2" expectedAllUsersAndTotals2 allUsersAndTotals2++ -- Dealing with nullable foreign keys+ allUnshippedOrders <-+ runSelectReturningList $+ select $ filter_ (\info -> isNothing_ info.orderShippingInfo)+ $ all_ (shoppingCart3Db ^. xshoppingCart3Orders)++ let expectedAllUnshippedOrders :: [Order]+ expectedAllUnshippedOrders = [jamesOrder1, jamesOrder2]++ liftIO $ assertEqual "allUnshippedOrders" expectedAllUnshippedOrders allUnshippedOrders++ -- .. in combination with aggregation+ shippingInformationByUser <-+ runSelectReturningList $+ select $ aggregate_ (\(user, order) ->+ 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)+ pure (user, order)++ let expectedShippingInformationByUser :: [(User, Int32, Int32)]+ expectedShippingInformationByUser = [+ (betty, 0, 1)+ , (james, 2, 0)+ , (sam, 1, 0) -- Incorrect value (expected problem, mentioned in tutorial)+ ]++ liftIO $ assertEqual "shippingInformationByUser"+ expectedShippingInformationByUser+ shippingInformationByUser++ -- Using implicit subselects++ shippingInformationByUser' <-+ runSelectReturningList $+ select $ do+ forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users)++ (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)+ 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)+ pure (pk user, order)++ guard_ (email' `references_` forUser)++ pure (forUser, unshippedCount, shippedCount)++ -- TODO: These numbers make no sense+ -- <https://github.com/haskell-beam/beam/issues/580>+ let expectedShippingInformationByUser' :: [(User, Int32, Int32)]+ expectedShippingInformationByUser' = [+ (betty, 1, 1)+ , (james, 2, 1)+ , (sam, 1, 1)+ ]++ liftIO $ assertEqual "shippingInformationByUser'"+ expectedShippingInformationByUser'+ shippingInformationByUser'++ -- Alternative formulation: using explicit subselects+ shippingInformationByUser'' <-+ runSelectReturningList $+ select $+ do forUser <- all_ (shoppingCart3Db ^. xshoppingCart3Users)++ (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)+ pure (pk user, order)++ guard_ (email `references_` forUser)++ (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)+ pure (pk user, order)+ guard_ (email' `references_` forUser)++ pure (forUser, unshippedCount, shippedCount)++ liftIO $ assertEqual "shippingInformationByUser''"+ expectedShippingInformationByUser'+ shippingInformationByUser''+ where+ james, betty, sam :: User+ james = User "james@example.com" "James" "Smith" "b4cc344d25a2efe540adbf2678e2304c"+ betty = User "betty@example.com" "Betty" "Jones" "82b054bd83ffad9b6cf8bdb98ce3cc2f"+ sam = User "sam@example.com" "Sam" "Taylor" "332532dcfaa1cbf61e2a266bd723612c"++ users :: [User]+ users = [james, betty, sam]++ addresses :: [AddressT (QExpr Sqlite s)]+ addresses = [+ Address default_ (val_ "123 Little Street") (val_ Nothing) (val_ "Boston") (val_ "MA") (val_ "12345") (val_ (pk james))+ , Address default_ (val_ "222 Main Street") (val_ (Just "Ste 1")) (val_ "Houston") (val_ "TX") (val_ "8888") (val_ (pk betty))+ , Address default_ (val_ "9999 Residence Ave") (val_ Nothing) (val_ "Sugarland") (val_ "TX") (val_ "8989") (val_ (pk betty))+ ]++ products :: [ProductT (QExpr Sqlite s)]+ products = [+ Product default_ (val_ "Red Ball") (val_ "A bright red, very spherical ball") (val_ 1000)+ , Product default_ (val_ "Math Textbook") (val_ "Contains a lot of important math theorems and formulae") (val_ 2500)+ , Product default_ (val_ "Intro to Haskell") (val_ "Learn the best programming language in the world") (val_ 3000)+ , Product default_ (val_ "Suitcase") "A hard durable suitcase" 15000+ ]++ addr1 :: Address+ addr1 = Address 1 "123 Little Street" Nothing "Boston" "MA" "12345" (pk james)++ info1 :: ShippingInfo+ info1 = ShippingInfo 1 USPS "12345790ABCDEFGHI"+++++++++
+ test/Test/Record/Beam/Util/Compat.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Test.Record.Beam.Util.Compat (+ countAll_+ ) where++import Data.Int+import Database.Beam.Backend.SQL+import Database.Beam.Query.Internal++-- This provides compatibility between beam 0.8 (where this returns Int)+-- and beam 0.9 (where this is polymorphic in the result type, but must be+-- instantiated to a type with an explicit bitwidth)+countAll_ :: BeamSqlBackend be => QAgg be s Int32+countAll_ = QExpr (pure countAllE)
+ test/Test/Record/Beam/Util/Orphans.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Record.Beam.Util.Orphans () where++import Database.Beam.Schema.Tables++deriving instance Eq (Ignored x)+deriving instance Show (Ignored x)++deriving instance Show (DatabaseEntityDescriptor be entityType) => Show (DatabaseEntity be db entityType)+deriving instance Eq (DatabaseEntityDescriptor be entityType) => Eq (DatabaseEntity be db entityType)++deriving instance Show (TableSettings tbl) => Show (DatabaseEntityDescriptor be (TableEntity tbl))+deriving instance Show (TableSettings tbl) => Show (DatabaseEntityDescriptor be (ViewEntity tbl))++deriving instance Eq (TableSettings tbl) => Eq (DatabaseEntityDescriptor be (TableEntity tbl))+deriving instance Eq (TableSettings tbl) => Eq (DatabaseEntityDescriptor be (ViewEntity tbl))++deriving instance Show (DatabaseEntityDescriptor be (DomainTypeEntity a))+deriving instance Eq (DatabaseEntityDescriptor be (DomainTypeEntity a))
+ test/Test/Record/Beam/Util/SQLite.hs view
@@ -0,0 +1,15 @@+module Test.Record.Beam.Util.SQLite (+ runInMemory+ -- * Re-exports+ , Sqlite+ ) where++import Control.Exception+import Database.Beam.Sqlite++import qualified Database.SQLite.Simple as SQLite++runInMemory :: (SQLite.Connection -> SqliteM a) -> IO a+runInMemory f =+ bracket (SQLite.open ":memory:") SQLite.close $ \conn ->+ runBeamSqlite conn $ f conn
+ test/Test/Record/Beam/Zipping.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}++module Test.Record.Beam.Zipping (tests) where++import Data.Functor.Identity+import Data.Kind+import Database.Beam+import Database.Beam.Schema.Tables+import Test.Tasty+import Test.Tasty.HUnit++import qualified GHC.Generics as GHC++import Data.Record.Beam ()++{-# ANN type TableA largeRecord #-}+data TableA (f :: Type -> Type) = TableA {+ taPrim :: PrimaryKey TableA f+ , taField :: Columnar f Bool+ , taMixin :: TableB f+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++{-# ANN type TableB largeRecord #-}+data TableB (f :: Type -> Type) = TableB {+ tbField :: Columnar f Char+ }+ deriving (Show, Eq)+ deriving anyclass (Beamable)++instance Table TableA where+ data PrimaryKey TableA f = PrimA (Columnar f Int)+ deriving stock (GHC.Generic)+ deriving anyclass (Beamable)++ primaryKey ta = ta.taPrim++deriving instance Show (Columnar f Int) => Show (PrimaryKey TableA f)+deriving instance Eq (Columnar f Int) => Eq (PrimaryKey TableA f)++tests :: TestTree+tests = testGroup "Test.Record.Beam.Zipping" [+ testCase "zipBeamFields" test_zipBeamFields+ ]++test_zipBeamFields :: Assertion+test_zipBeamFields =+ assertEqual "" (runIdentity (zipBeamFieldsM apply fnA argA)) resA+ where+ apply :: forall a.+ Columnar' EndoFn a+ -> Columnar' Identity a+ -> Identity (Columnar' Identity a)+ apply (Columnar' (EndoFn f)) (Columnar' x) = Identity (Columnar' (f x))++ fnA :: TableA EndoFn+ fnA = TableA {+ taPrim = PrimA (EndoFn succ)+ , taField = EndoFn not+ , taMixin = fnB+ }++ fnB :: TableB EndoFn+ fnB = TableB {+ tbField = EndoFn pred+ }++ argA :: TableA Identity+ argA = TableA {+ taPrim = PrimA 5+ , taField = True+ , taMixin = argB+ }++ argB :: TableB Identity+ argB = TableB {+ tbField = 'y'+ }++ resA :: TableA Identity+ resA = TableA {+ taPrim = PrimA 6+ , taField = False+ , taMixin = resB+ }++ resB :: TableB Identity+ resB = TableB {+ tbField = 'x'+ }++newtype EndoFn a = EndoFn (a -> a)
+ test/TestBeamLargeRecords.hs view
@@ -0,0 +1,20 @@+module Main (main) where++import Test.Tasty++import qualified Test.Record.Beam.Andres+import qualified Test.Record.Beam.SimpleSQL+import qualified Test.Record.Beam.Tutorial1+import qualified Test.Record.Beam.Tutorial2+import qualified Test.Record.Beam.Tutorial3+import qualified Test.Record.Beam.Zipping++main :: IO ()+main = defaultMain $ testGroup "beam-large-records" [+ Test.Record.Beam.Andres.tests+ , Test.Record.Beam.SimpleSQL.tests+ , Test.Record.Beam.Tutorial1.tests+ , Test.Record.Beam.Tutorial2.tests+ , Test.Record.Beam.Tutorial3.tests+ , Test.Record.Beam.Zipping.tests+ ]