diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,21 @@ +# 0.10.1.0 + +# Added features + + * Allow embedding database types + * Loosen some version bounds + +# 0.10.0.0 + +# Bug fixes + + * Make sure lateral join names do not overlap + +# Addded features + + * Add `runSelectReturningFirst` + * `IN (SELECT ...)` syntax via `inQuery_` + # 0.9.2.1 ## Added features diff --git a/Database/Beam/Backend/SQL/Row.hs b/Database/Beam/Backend/SQL/Row.hs --- a/Database/Beam/Backend/SQL/Row.hs +++ b/Database/Beam/Backend/SQL/Row.hs @@ -20,6 +20,7 @@ import Control.Applicative import Control.Exception (Exception) +import Control.Monad import Control.Monad.Free.Church import Control.Monad.Identity import Data.Kind (Type) diff --git a/Database/Beam/Query/CTE.hs b/Database/Beam/Query/CTE.hs --- a/Database/Beam/Query/CTE.hs +++ b/Database/Beam/Query/CTE.hs @@ -8,6 +8,7 @@ import Database.Beam.Query.Internal import Database.Beam.Query.Types +import Control.Monad.Fix import Control.Monad.Free.Church import Control.Monad.Writer hiding ((<>)) import Control.Monad.State.Strict diff --git a/Database/Beam/Schema/Lenses.hs b/Database/Beam/Schema/Lenses.hs --- a/Database/Beam/Schema/Lenses.hs +++ b/Database/Beam/Schema/Lenses.hs @@ -10,6 +10,7 @@ import Control.Monad.Identity +import Data.Function import Data.Kind (Type) import Data.Proxy diff --git a/Database/Beam/Schema/Tables.hs b/Database/Beam/Schema/Tables.hs --- a/Database/Beam/Schema/Tables.hs +++ b/Database/Beam/Schema/Tables.hs @@ -25,7 +25,7 @@ , withTableModification, modifyTable, modifyEntityName , setEntityName, modifyTableFields, fieldNamed , modifyEntitySchema, setEntitySchema - , defaultDbSettings + , defaultDbSettings, embedDatabase , RenamableWithRule(..), RenamableField(..) , FieldRenamer(..) @@ -70,6 +70,7 @@ import Data.Char (isUpper, toLower) import Data.Foldable (fold) import qualified Data.List.NonEmpty as NE +import Data.Monoid import Data.Proxy import Data.String (IsString(..)) import Data.Text (Text) @@ -204,7 +205,6 @@ runIdentity $ zipBeamFieldsM (\(Columnar' field :: Columnar' f a) (Columnar' (FieldModification fieldFn :: FieldModification f a)) -> pure (Columnar' (fieldFn field))) tbl mods - -- | Provide an 'EntityModification' for 'TableEntity's. Allows you to modify -- the name of the table and provide a modification for each field in the -- table. See the examples for 'withDbModification' for more. @@ -230,6 +230,14 @@ setEntitySchema :: IsDatabaseEntity be entity => Maybe Text -> EntityModification (DatabaseEntity be db) be entity setEntitySchema nm = modifyEntitySchema (\_ -> nm) +-- | Embed database settings in a larger database +embedDatabase :: forall be embedded db. Database be embedded => DatabaseSettings be embedded -> embedded (EntityModification (DatabaseEntity be db) be) +embedDatabase db = + runIdentity $ + zipTables (Proxy @be) + (\(DatabaseEntity x) _ -> pure (EntityModification (Endo (\_ -> DatabaseEntity x)))) + db db + -- | Construct an 'EntityModification' to rename the fields of a 'TableEntity' modifyTableFields :: tbl (FieldModification (TableField tbl)) -> EntityModification (DatabaseEntity be db) be (TableEntity tbl) modifyTableFields modFields = EntityModification (Endo (\(DatabaseEntity tbl@(DatabaseTable {})) -> DatabaseEntity tbl { dbTableSettings = withTableModification modFields (dbTableSettings tbl) })) @@ -397,6 +405,16 @@ GAutoDbSettings (S1 f (K1 Generic.R (DatabaseEntity be db x)) p) where autoDbSettings' = M1 (K1 (DatabaseEntity (dbEntityAuto name))) where name = T.pack (selName (undefined :: S1 f (K1 Generic.R (DatabaseEntity be db x)) p)) +instance ( Database be embedded + , Generic (DatabaseSettings be embedded) + , GAutoDbSettings (Rep (DatabaseSettings be embedded) ()) ) => + GAutoDbSettings (S1 f (K1 Generic.R (embedded (DatabaseEntity be super))) p) where + autoDbSettings' = + M1 . K1 . runIdentity $ + zipTables (Proxy @be) + (\(DatabaseEntity x) _ -> pure (DatabaseEntity x)) + db db + where db = defaultDbSettings @be class GZipDatabase be f g h x y z where gZipDatabase :: Applicative m => @@ -416,6 +434,11 @@ gZipDatabase _ combine ~(K1 x) ~(K1 y) = K1 <$> combine x y +instance Database be db => + GZipDatabase be f g h (K1 Generic.R (db f)) (K1 Generic.R (db g)) (K1 Generic.R (db h)) where + + gZipDatabase _ combine ~(K1 x) ~(K1 y) = + K1 <$> zipTables (Proxy @be) combine x y data Lenses (t :: (Type -> Type) -> Type) (f :: Type -> Type) x data LensFor t x where diff --git a/beam-core.cabal b/beam-core.cabal --- a/beam-core.cabal +++ b/beam-core.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: beam-core -version: 0.10.0.0 +version: 0.10.1.0 synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. Beam is modular and supports various backends. In order to use beam, you will need to use @@ -64,17 +64,17 @@ aeson >=0.11 && <2.2, text >=1.2.2.0 && <2.1, bytestring >=0.10 && <0.12, - mtl >=2.2.1 && <2.3, + mtl >=2.2.1 && <2.4, microlens >=0.4 && <0.5, - ghc-prim >=0.5 && <0.10, - free >=4.12 && <5.2, + ghc-prim >=0.5 && <0.11, + free >=4.12 && <5.3, dlist >=0.7.1.2 && <1.1, time >=1.6 && <1.13, hashable >=1.2.4.0 && <1.5, network-uri >=2.6 && <2.7, containers >=0.5 && <0.7, scientific >=0.3 && <0.4, - vector >=0.11 && <0.13, + vector >=0.11 && <0.14, vector-sized >=0.5 && <1.6, tagged >=0.8 && <0.9 @@ -101,7 +101,7 @@ hs-source-dirs: test main-is: Main.hs other-modules: Database.Beam.Test.Schema Database.Beam.Test.SQL - build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit + build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit, microlens default-language: Haskell2010 default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, GADTs, TypeFamilies, DeriveGeneric, DefaultSignatures, RankNTypes, StandaloneDeriving, KindSignatures, diff --git a/test/Database/Beam/Test/Schema.hs b/test/Database/Beam/Test/Schema.hs --- a/test/Database/Beam/Test/Schema.hs +++ b/test/Database/Beam/Test/Schema.hs @@ -23,6 +23,8 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) +import Lens.Micro.Extras (view) + import Test.Tasty import Test.Tasty.HUnit @@ -34,9 +36,8 @@ , parametricAndFixedNestedBeamsAreEquivalent -- , automaticNestedFieldsAreUnset -- , nullableForeignKeysGivenMaybeType - , underscoresAreHandledGracefully ] --- , dbSchemaGeneration ] --- , dbSchemaModification ] + , underscoresAreHandledGracefully + , embeddedDatabases ] data DummyBackend @@ -315,34 +316,38 @@ Nothing -> defName Just _ -> "pfx_" <> defName) --- employeeDbSettingsModified :: DatabaseSettings EmployeeDb --- employeeDbSettingsModified = --- defaultDbSettings `withDbModifications` --- (modifyingDb { _employees = tableModification (\_ -> "emps") tableFieldsModification --- , _departments = tableModification (\_ -> "depts") --- (tableFieldsModification --- { _departmentName = fieldModification (\_ -> "depts_name") id }) }) +data VehicleDb f + = VehicleDb + { _vdbVehiculesA :: f (TableEntity ADepartmentVehiculeT) + , _vdbVehiculesB :: f (TableEntity BDepartmentVehiculeT) + } deriving Generic +instance Database be VehicleDb --- dbSchemaGeneration :: TestTree --- dbSchemaGeneration = --- testCase "Database schema generation" $ --- do let names = allTables (\(DatabaseTable _ nm _) -> nm) employeeDbSettings --- names @?= [ "employees" --- , "departments" --- , "roles" --- , "funny" ] +data SuperDb f + = SuperDb + { _embedEmployeeDb :: EmployeeDb f + , _embedVehicleDb :: VehicleDb f + } deriving Generic +instance Database be SuperDb --- dbSchemaModification :: TestTree --- dbSchemaModification = --- testCase "Database schema modification" $ --- do let names = allTables (\(DatabaseTable _ nm _ ) -> nm) employeeDbSettingsModified --- names @?= [ "emps" --- , "depts" --- , "roles" --- , "funny" ] +superDbSettingsDefault :: DatabaseSettings be SuperDb +superDbSettingsDefault = defaultDbSettings --- let DatabaseTable _ _ departmentT = _departments employeeDbSettingsModified --- departmentT @?= DepartmentT (TableField "depts_name" (DummyField False False DummyFieldText)) --- (EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) --- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText))) --- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime)))) +superDbSettingsCustom :: DatabaseSettings be SuperDb +superDbSettingsCustom = defaultDbSettings `withDbModification` dbModification { _embedVehicleDb = embedDatabase customVehicleDb } + +customVehicleDb :: DatabaseSettings be VehicleDb +customVehicleDb = defaultDbSettings `withDbModification` dbModification + { _vdbVehiculesA = setEntityName "something_random" } + + +embeddedDatabases :: TestTree +embeddedDatabases = + testGroup "Embedded databases" + [ testCase "Databases can be embedded" $ do + view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesA (_embedVehicleDb superDbSettingsDefault)) @?= "vehicules_a" + view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesB (_embedVehicleDb superDbSettingsDefault)) @?= "vehicules_b" + , testCase "Databases can be customized when embedded" $ do + view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesA (_embedVehicleDb superDbSettingsCustom)) @?= "something_random" + ] +