allow database embedding (#661)

* allow database embedding

* Add documentation for database embedding

* Make sure embed Database produces a modification?

* Get the types just right

beam-core/Database/Beam/Schema/Tables.hs

@@ -25,7 +25,7 @@ module Database.Beam.Schema.Tables
     , withTableModification, modifyTable, modifyEntityName
     , setEntityName, modifyTableFields, fieldNamed
     , modifyEntitySchema, setEntitySchema
-    , defaultDbSettings
+    , defaultDbSettings, embedDatabase
 
     , RenamableWithRule(..), RenamableField(..)
     , FieldRenamer(..)
@@ -204,7 +204,6 @@ withTableModification mods tbl =
   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 +229,14 @@ setEntityName nm = modifyEntityName (\_ -> nm)
 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 +404,16 @@ instance ( Selector f, IsDatabaseEntity be x, DatabaseEntityDefaultRequirements
   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 +433,11 @@ instance (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) =>
 
   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

beam-core/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
@@ -101,7 +101,7 @@ test-suite beam-core-tests
   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,

beam-core/test/Database/Beam/Test/Schema.hs

@@ -23,6 +23,8 @@ import           Data.Text (Text)
 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 @@ tests = testGroup "Schema Tests"
                   , parametricAndFixedNestedBeamsAreEquivalent
 --                  , automaticNestedFieldsAreUnset
 --                  , nullableForeignKeysGivenMaybeType
-                  , underscoresAreHandledGracefully ]
---                  , dbSchemaGeneration ]
---                  , dbSchemaModification ]
+                  , underscoresAreHandledGracefully
+                  , embeddedDatabases ]
 
 data DummyBackend
 
@@ -315,34 +316,38 @@ employeeDbSettingsRuleMods = defaultDbSettings `withDbModification`
                                                   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 }) })
-
--- dbSchemaGeneration :: TestTree
--- dbSchemaGeneration =
---   testCase "Database schema generation" $
---   do let names = allTables (\(DatabaseTable _ nm _) -> nm) employeeDbSettings
---      names @?= [ "employees"
---                , "departments"
---                , "roles"
---                , "funny" ]
-
--- dbSchemaModification :: TestTree
--- dbSchemaModification =
---   testCase "Database schema modification" $
---   do let names = allTables (\(DatabaseTable _ nm _ ) -> nm) employeeDbSettingsModified
---      names @?= [ "emps"
---                , "depts"
---                , "roles"
---                , "funny" ]
-
---      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))))
+data VehicleDb f
+    = VehicleDb
+    { _vdbVehiculesA :: f (TableEntity ADepartmentVehiculeT)
+    , _vdbVehiculesB :: f (TableEntity BDepartmentVehiculeT)
+    } deriving Generic
+instance Database be VehicleDb
+
+data SuperDb f
+    = SuperDb
+    { _embedEmployeeDb :: EmployeeDb f
+    , _embedVehicleDb  :: VehicleDb f
+    } deriving Generic
+instance Database be SuperDb
+
+superDbSettingsDefault :: DatabaseSettings be SuperDb
+superDbSettingsDefault = defaultDbSettings
+
+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"
+      ]
+

docs/user-guide/databases.md

@@ -237,3 +237,43 @@ exampleDb = defaultDbSettings `withDbModification`
                           }
             }
 ```
+
+## Embedding
+
+You can freely include databases in one another. For example, suppose
+you had another database `ResourcesDb` defined elsewhere and you
+wanted to combine it with the `ExampleDb` above. You can create a
+`SuperDb` type as follows:
+
+```haskell
+data SuperDb f
+    = SuperDb
+    { example :: ExampleDb f
+    , resources :: ResourcesDb f
+    } deriving (Generic, Beamable)
+```
+
+Databases containing other databases can have their settings
+constructed, as usual.
+
+```haskell
+superDbDefault :: DatabaseSettings be SuperDb
+superDbDefault = defaultDbSettings
+```
+
+By default, embedding databases does not change any of the table
+names. This is done so that you can create larger databases out of
+smaller ones without having to worry about manually editing their
+names. Typically database decomposition is done when you want to
+define databases that only access particular subsets of tables. Thus,
+re-composing back together should not change the names.
+
+Of coures, embedded databases can be modified as well. To include our
+renamed `exampleDb` above, simply use the `embedDatabase`
+modification.
+
+```haskell
+superDbCustom :: DatabaseSettings be SuperDb
+superDbCustom = defaultDbSettings `withDbModification`
+                dbModification { example = exampleDb }
+```