Implement predicateRestrictsDropOf

Author: Martoon-00

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

@@ -408,6 +408,9 @@ dropColumnProvider = ActionProvider provider
 --           TableHasColumn tblNm' colNm' colType' :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <-
 --             findPostConditions
 --           guard (tblNm' == tblNm && colNm == colNm' && colType == colType') -- This column exists as a different type
+         ensuringNot_ $ do
+            SomeDatabasePredicate pred' <- findPreConditions
+            guard (pred' `predicateRestrictsDropOf` colP)
 
          relatedPreds <- --pure []
            pure $ do p'@(SomeDatabasePredicate pred') <- findPreConditions

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

@@ -5,24 +5,28 @@
 -- | Defines common 'DatabasePredicate's that are shared among backends
 module Database.Beam.Migrate.Checks where
 
+import Control.Monad (guard)
+
 import Database.Beam.Migrate.Serialization
 import Database.Beam.Migrate.Types.Predicates
 import Database.Beam.Migrate.SQL.SQL92
 import Database.Beam.Schema.Indices
 import Database.Beam.Schema.Tables
 
+import Data.Proxy (Proxy (..))
 import Data.Aeson ((.:), (.=), withObject, object)
 import Data.Aeson.Types (Parser, Value)
 import Data.Hashable (Hashable(..))
 import Data.Text (Text)
-import Data.Typeable (Typeable, cast)
+import Data.Typeable (typeOf, splitTyConApp, typeRep, Typeable, cast)
 #if !MIN_VERSION_base(4, 11, 0)
 import           Data.Semigroup
 #endif
 
 import GHC.Generics (Generic)
 import GHC.Exts (fromList, toList)
 
+import Unsafe.Coerce (unsafeCoerce)
 
 -- * Table checks
 
@@ -152,12 +156,24 @@ instance DatabasePredicate TableHasIndex where
     | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm
     | otherwise = False
 
-  -- TODO: how to say that we cannot delete a column while an index on it exists?
-  -- The following does not work since 'TableHasColumn' is polymorphic other used syntax, and
-  -- we don't know which index to get here
-  --
-  -- predicateRestrictDropOf (TableHasIndex tblNm _) p'
-  --   | Just (TableHasColumn tblNm' _ _) <- cast p' = tblNm' == tblNm
+  predicateRestrictsDropOf (TableHasIndex tblNm colNms _) p'
+    | Just (tblNm', colNm') <-
+        withTyCon (\(TableHasColumn tblNm' colNm' _) -> (tblNm', colNm')) p' =
+          tblNm == tblNm' && (colNm' `elem` colNms)
+    | otherwise = False
+
+-- | Match a given item's type against a type-level application with the given
+-- type constructor. Applies the given function and returns 'Just' its result on match,
+-- 'Nothing' otherwise.
+withTyCon
+    :: forall (con :: * -> *) (item :: *) r.
+       (Typeable con, Typeable item)
+    => (forall c. con c -> r) -> item -> Maybe r
+withTyCon f x = do
+    let (tyItemCon, _) = splitTyConApp $ typeRep (Proxy @item)
+        (tyCon, _)     = splitTyConApp (typeOf x)
+    guard (tyItemCon == tyCon)
+    return (f $ unsafeCoerce x)
 
 -- | Convert gathered indices into checks.
 entityIndicesToChecks

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

@@ -47,8 +47,8 @@ class (Typeable p, Hashable p, Eq p) => DatabasePredicate p where
   -- needs another one to be true in order to exist. The difference is, the other
   -- predicate cannot be removed until this one exists, this predicate has to be
   -- explicitely removed with a corresponding action first.
-  predicateRestrictDropOf :: DatabasePredicate p' => p -> p' -> Bool
-  predicateRestrictDropOf _ _ = False
+  predicateRestrictsDropOf :: DatabasePredicate p' => p -> p' -> Bool
+  predicateRestrictsDropOf _ _ = False
 
 -- | A Database predicate is a value of any type which satisfies
 -- 'DatabasePredicate'. We often want to store these in lists and sets, so we