Make mkDFunUnfolding more robust

[ghc-hetmet.git] / compiler / typecheck / TcType.lhs

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index b2da9f0..c68c10f 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -28,7 +28,7 @@ module TcType (
   MetaDetails(Flexi, Indirect), MetaInfo(..), 
   SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy,
-  isSigTyVar, isExistentialTyVar,  isTyConableTyVar,
+  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,
   metaTvRef, 
   isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol,
 
@@ -614,7 +614,7 @@ isImmutableTyVar tv
   | isTcTyVar tv = isSkolemTyVar tv
   | otherwise    = True
 
-isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, 
+isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
   isMetaTyVar :: TcTyVar -> Bool 
 
 isTyConableTyVar tv    
@@ -633,11 +633,14 @@ isSkolemTyVar tv
         FlatSkol {} -> True
        MetaTv {}   -> False
 
-isExistentialTyVar tv  -- Existential type variable, bound by a pattern
+-- isOverlappableTyVar has a unique purpose.
+-- See Note [Binding when looking up instances] in InstEnv.
+isOverlappableTyVar tv
   = ASSERT( isTcTyVar tv )
     case tcTyVarDetails tv of
-       SkolemTv (PatSkol {}) -> True
-       _                     -> False
+        SkolemTv (PatSkol {})  -> True
+        SkolemTv (InstSkol {}) -> True
+        _                      -> False
 
 isMetaTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
@@ -916,23 +919,24 @@ tcIsTyVarTy :: Type -> Bool
 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 
 -----------------------
-tcSplitDFunTy :: Type -> ([TyVar], Class, [Type])
+tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
 -- Split the type of a dictionary function
 -- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
 -- have non-Pred arguments, such as
 --     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 tcSplitDFunTy ty 
-  = case tcSplitForAllTys ty                 of { (tvs, rho)  ->
-    case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> 
-    (tvs, clas, tys) }}
+  = case tcSplitForAllTys ty   of { (tvs, rho)  ->
+    case split_dfun_args 0 rho of { (n_theta, tau) ->
+    case tcSplitDFunHead tau   of { (clas, tys) ->
+    (tvs, n_theta, clas, tys) }}}
   where
-    -- Discard the context of the dfun.  This can be a mix of
+    -- Count the context of the dfun.  This can be a mix of
     -- coercion and class constraints; or (in the general NDP case)
     -- some other function argument
-    drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty'
-    drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty
-    drop_pred_tys (FunTy _ ty)     = drop_pred_tys ty
-    drop_pred_tys ty               = ty
+    split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
+    split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
+    split_dfun_args n (FunTy _ ty)     = split_dfun_args (n+1) ty
+    split_dfun_args n ty               = (n, ty)
 
 tcSplitDFunHead :: Type -> (Class, [Type])
 tcSplitDFunHead tau  
@@ -953,6 +957,9 @@ tcInstHeadTyAppAllTyVars :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
 -- These must be a constructor applied to type variable arguments
 tcInstHeadTyAppAllTyVars ty
+  | Just ty' <- tcView ty       -- Look through synonyms
+  = tcInstHeadTyAppAllTyVars ty'
+  | otherwise
   = case ty of
        TyConApp _ tys  -> ok tys
        FunTy arg res   -> ok [arg, res]