X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FUnify.lhs;h=b96f20724e7b54e18b1204539c74fe960a87fc55;hb=9f8e195e69e54c733eb93b2e2e39c2ebe818ce62;hp=f60c7bee6190064fa8d1b4a2e4488dfad8960e14;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index f60c7be..b96f207 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -7,7 +7,7 @@ module Unify (
 
 	gadtRefineTys, BindFlag(..),
 
-	coreRefineTys, TypeRefinement,
+	coreRefineTys, dataConCanMatch, TypeRefinement,
 
 	-- Re-export
 	MaybeErr(..)
@@ -23,7 +23,7 @@ import Type		( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
 			  TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX,
 			  mkOpenTvSubst, tcView )
 import TypeRep          ( Type(..), PredType(..), funTyCon )
-import DataCon 		( DataCon, dataConInstResTy )
+import DataCon 		( DataCon, isVanillaDataCon, dataConResTys, dataConInstResTy )
 import Util		( snocView )
 import ErrUtils		( Message )
 import Outputable
@@ -222,6 +222,17 @@ tcUnifyTys bind_fn tys1 tys2
     tvs2 = tyVarsOfTypes tys2
 
 ----------------------------
+dataConCanMatch :: DataCon -> [Type] -> Bool
+-- Returns True iff the data con can match a scrutinee of type (T tys)
+--		    where T is the type constructor for the data con
+dataConCanMatch con tys
+  | isVanillaDataCon con
+  = True
+  | otherwise
+  = isSuccess $ initUM (\tv -> BindMe) $
+    unify_tys emptyTvSubstEnv (dataConResTys con) tys
+
+----------------------------
 coreRefineTys :: DataCon -> [TyVar]	-- Case pattern (con tv1 .. tvn ...)
 	      -> Type			-- Type of scrutinee
 	      -> Maybe TypeRefinement