Add convenience accessors

Author: tathougies

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

@@ -19,6 +19,7 @@ module Database.Beam.Schema.Tables
     , DatabaseEntityDescriptor(..)
     , DatabaseEntity(..), TableEntity, ViewEntity, DomainTypeEntity
     , dbEntityDescriptor
+    , dbName, dbSchema, dbTableFields
     , DatabaseModification, EntityModification(..)
     , FieldModification(..)
     , dbModification, tableModification, withDbModification
@@ -96,7 +97,6 @@ import           GHC.TypeLits
 import           GHC.Types
 
 import           Lens.Micro hiding (to)
-import qualified Lens.Micro as Lens
 
 -- | Allows introspection into database types.
 --
@@ -311,7 +311,7 @@ class RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be entityType))
   type DatabaseEntityRegularRequirements be entityType :: Constraint
 
   dbEntityName :: Lens' (DatabaseEntityDescriptor be entityType) Text
-  dbEntitySchema :: Traversal' (DatabaseEntityDescriptor be entityType) (Maybe Text)
+  dbEntitySchema :: Lens' (DatabaseEntityDescriptor be entityType) (Maybe Text)
 
   dbEntityAuto :: DatabaseEntityDefaultRequirements be entityType =>
                   Text -> DatabaseEntityDescriptor be entityType
@@ -387,7 +387,7 @@ instance IsDatabaseEntity be (DomainTypeEntity ty) where
   type DatabaseEntityRegularRequirements be (DomainTypeEntity ty) = ()
 
   dbEntityName f (DatabaseDomainType s t) = DatabaseDomainType s <$> f t
-  dbEntitySchema f (DatabaseDomainType s t) = DatabaseDomainType <$> f s <*> pure t
+  dbEntitySchema f (DatabaseDomainType s t) = (\s' -> DatabaseDomainType s' t) <$> f s
   dbEntityAuto = DatabaseDomainType Nothing
 
 -- | Represents a meta-description of a particular entityType. Mostly, a wrapper
@@ -398,8 +398,21 @@ data DatabaseEntity be (db :: (Type -> Type) -> Type) entityType  where
       IsDatabaseEntity be entityType =>
       DatabaseEntityDescriptor be entityType ->  DatabaseEntity be db entityType
 
-dbEntityDescriptor :: SimpleGetter (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
-dbEntityDescriptor = Lens.to (\(DatabaseEntity e) -> e)
+dbEntityDescriptor :: Lens' (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)
+dbEntityDescriptor f (DatabaseEntity d) = DatabaseEntity <$> f d
+
+dbName :: IsDatabaseEntity be entityType => Lens' (DatabaseEntity be db entityType) Text
+dbName = dbEntityDescriptor . dbEntityName
+
+dbSchema :: IsDatabaseEntity be entityType => Lens' (DatabaseEntity be db entityType) (Maybe Text)
+dbSchema = dbEntityDescriptor . dbEntitySchema
+
+dbTableFields :: Lens' (DatabaseEntity be db (TableEntity table)) (TableSettings table)
+dbTableFields = dbEntityDescriptor . (\f DatabaseTable { dbTableSchema = sch
+                                                       , dbTableOrigName = nm
+                                                       , dbTableCurrentName = curNm
+                                                       , dbTableSettings = s } ->
+                                      DatabaseTable sch nm curNm <$> f s)
 
 -- | When parameterized by this entity tag, a database type will hold
 --   meta-information on the Haskell mappings of database entities. Under the

beam-migrate/Database/Beam/Migrate/Backend.hs

@@ -34,6 +34,7 @@ module Database.Beam.Migrate.Backend
   , sql92HsPredicateConverters
   , hasColumnConverter
   , trivialHsConverter, hsPredicateConverter
+  , withExtraPredicateParsers
 
   -- * For tooling authors
   , SomeBeamMigrationBackend(..), SomeCheckedDatabaseSettings(..) )
@@ -93,6 +94,9 @@ data BeamMigrationBackend be m where
     , backendConnect :: String -> IO (BeamMigrateConnection be m)
     } -> BeamMigrationBackend be m
 
+withExtraPredicateParsers :: BeamMigrationBackend be m -> BeamDeserializers be -> BeamMigrationBackend be m
+withExtraPredicateParsers be ds = be { backendPredicateParsers = backendPredicateParsers be <> ds }
+
 data BeamMigrateConnection be m where
     BeamMigrateConnection
         :: { backendRun :: forall a. m a -> IO (Either DdlError a)

beam-migrate/Database/Beam/Migrate/Types.hs

@@ -13,7 +13,8 @@ module Database.Beam.Migrate.Types
   , CheckedDatabaseEntity(..)
 
   , unCheckDatabase, collectChecks
-  , renameCheckedEntity
+  , unCheckedDbLens
+  , renameCheckedEntity, checkedDbDescriptor
 
     -- ** Modifyinging checked entities
     --

beam-migrate/Database/Beam/Migrate/Types/CheckedEntities.hs

@@ -63,6 +63,11 @@ data CheckedDatabaseEntity be (db :: (Type -> Type) -> Type) entityType where
                         -> [ SomeDatabasePredicate ]
                         -> CheckedDatabaseEntity be db entityType
 
+checkedDbDescriptor :: Lens' (CheckedDatabaseEntity be db entityType)
+                             (CheckedDatabaseEntityDescriptor be entityType)
+checkedDbDescriptor fn (CheckedDatabaseEntity f ps) =
+    (\f' -> CheckedDatabaseEntity f' ps) <$> fn f
+
 -- | The type of a checked database descriptor. Conceptually, this is just a
 -- 'DatabaseSettings' with a set of predicates. Use 'unCheckDatabase' to get the
 -- regular 'DatabaseSettings' object and 'collectChecks' to access the
@@ -78,6 +83,10 @@ renameCheckedEntity renamer =
 unCheckDatabase :: forall be db. Database be db => CheckedDatabaseSettings be db -> DatabaseSettings be db
 unCheckDatabase db = runIdentity $ zipTables (Proxy @be) (\(CheckedDatabaseEntity x _) _ -> pure $ DatabaseEntity (unCheck x)) db db
 
+unCheckedDbLens :: forall be db. Database be db => Lens' (CheckedDatabaseSettings be db) (DatabaseSettings be db)
+unCheckedDbLens f db =
+    (\db' -> runIdentity (zipTables (Proxy @be) (\(CheckedDatabaseEntity d cks) d' -> pure (CheckedDatabaseEntity (d & unChecked .~ (d' ^. dbEntityDescriptor)) cks)) db db')) <$> f (unCheckDatabase db)
+
 -- | A @beam-migrate@ database schema is defined completely by the set of
 -- predicates that apply to it. This function allows you to access this
 -- definition for a 'CheckedDatabaseSettings' object.