diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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`) diff --git a/beam-large-records.cabal b/beam-large-records.cabal new file mode 100644 --- /dev/null +++ b/beam-large-records.cabal @@ -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 diff --git a/src/Data/Record/Beam.hs b/src/Data/Record/Beam.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam.hs @@ -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 + diff --git a/src/Data/Record/Beam/Constraints.hs b/src/Data/Record/Beam/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/Constraints.hs @@ -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)))) diff --git a/src/Data/Record/Beam/DbSettings.hs b/src/Data/Record/Beam/DbSettings.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/DbSettings.hs @@ -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 + diff --git a/src/Data/Record/Beam/FromBackendRow.hs b/src/Data/Record/Beam/FromBackendRow.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/FromBackendRow.hs @@ -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)))) diff --git a/src/Data/Record/Beam/Internal.hs b/src/Data/Record/Beam/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/Internal.hs @@ -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 + diff --git a/src/Data/Record/Beam/Interpretation.hs b/src/Data/Record/Beam/Interpretation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/Interpretation.hs @@ -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) diff --git a/src/Data/Record/Beam/Lenses.hs b/src/Data/Record/Beam/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/Lenses.hs @@ -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) diff --git a/src/Data/Record/Beam/Skeleton.hs b/src/Data/Record/Beam/Skeleton.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/Skeleton.hs @@ -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 diff --git a/src/Data/Record/Beam/ZipDatabase.hs b/src/Data/Record/Beam/ZipDatabase.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/ZipDatabase.hs @@ -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 diff --git a/src/Data/Record/Beam/ZipTables.hs b/src/Data/Record/Beam/ZipTables.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Beam/ZipTables.hs @@ -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) + + diff --git a/test/Test/Record/Beam/Andres.hs b/test/Test/Record/Beam/Andres.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Andres.hs @@ -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 +-- +-- +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") + } + diff --git a/test/Test/Record/Beam/SimpleSQL.hs b/test/Test/Record/Beam/SimpleSQL.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/SimpleSQL.hs @@ -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] + diff --git a/test/Test/Record/Beam/Tutorial1.hs b/test/Test/Record/Beam/Tutorial1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Tutorial1.hs @@ -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 +-------------------------------------------------------------------------------} + +{-# 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" + } + diff --git a/test/Test/Record/Beam/Tutorial2.hs b/test/Test/Record/Beam/Tutorial2.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Tutorial2.hs @@ -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" + diff --git a/test/Test/Record/Beam/Tutorial3.hs b/test/Test/Record/Beam/Tutorial3.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Tutorial3.hs @@ -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. + -- + 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 + -- + 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" + + + + + + + + + diff --git a/test/Test/Record/Beam/Util/Compat.hs b/test/Test/Record/Beam/Util/Compat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Util/Compat.hs @@ -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) diff --git a/test/Test/Record/Beam/Util/Orphans.hs b/test/Test/Record/Beam/Util/Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Util/Orphans.hs @@ -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)) diff --git a/test/Test/Record/Beam/Util/SQLite.hs b/test/Test/Record/Beam/Util/SQLite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Util/SQLite.hs @@ -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 diff --git a/test/Test/Record/Beam/Zipping.hs b/test/Test/Record/Beam/Zipping.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Beam/Zipping.hs @@ -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) diff --git a/test/TestBeamLargeRecords.hs b/test/TestBeamLargeRecords.hs new file mode 100644 --- /dev/null +++ b/test/TestBeamLargeRecords.hs @@ -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 + ]