Implement predicateRestrictsDropOf

Author: Martoon-00

Diff for: beam-migrate/Database/Beam/Migrate/Actions.hs

@@ -418,6 +418,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

Diff for: beam-migrate/Database/Beam/Migrate/Checks.hs

@@ -5,7 +5,9 @@
 -- | Defines common 'DatabasePredicate's that are shared among backends
 module Database.Beam.Migrate.Checks where
 
+import Control.Monad (guard)
 import Database.Beam.Backend.SQL.SQL92
+
 import Database.Beam.Migrate.Serialization
 import Database.Beam.Migrate.SQL.SQL92
 import Database.Beam.Migrate.SQL.Types
@@ -16,15 +18,18 @@ import Database.Beam.Schema.Tables
 import Data.Aeson (object, withObject, (.:), (.=))
 import Data.Aeson.Types (Parser, Value)
 import Data.Hashable (Hashable (..))
+import Data.Proxy (Proxy (..))
 import Data.Text (Text)
-import Data.Typeable (Typeable, cast)
+import Data.Typeable (Typeable, cast, splitTyConApp, typeOf, typeRep)
 #if !MIN_VERSION_base(4, 11, 0)
 import Data.Semigroup
 #endif
 
 import GHC.Exts (fromList, toList)
 import GHC.Generics (Generic)
 
+import Unsafe.Coerce (unsafeCoerce)
+
 -- * Table checks
 
 -- | Asserts that a table with the given name exists in a database
@@ -153,12 +158,25 @@ 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.
+-- Unlike 'cast', this function does not require @a@ type to be instance of 'Typeable'.
+withTyCon
+    :: forall (con :: * -> *) (item :: *) r.
+       (Typeable con, Typeable item)
+    => (forall a. con a -> r) -> item -> Maybe r
+withTyCon f x = do
+    (itemTyCon, itemTyArgs@(_ : _)) <- pure $ splitTyConApp (typeOf x)
+    (conTyCon, conTyArgs) <- pure $ splitTyConApp (typeRep (Proxy @con))
+    guard (itemTyCon == conTyCon && init itemTyArgs == conTyArgs)
+    return (f $ unsafeCoerce x)
 
 -- | Convert gathered indices into checks.
 entityIndicesToChecks

Diff for: beam-migrate/Database/Beam/Migrate/Types/Predicates.hs

@@ -57,8 +57,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