Make mkDFunUnfolding more robust

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

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 194deb9..c68c10f 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -28,9 +28,9 @@ module TcType (
   MetaDetails(Flexi, Indirect), MetaInfo(..), 
   SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy,
-  isSigTyVar, isExistentialTyVar,  isTyConableTyVar,
+  isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,
   metaTvRef, 
-  isFlexi, isIndirect, isRuntimeUnk, isUnk,
+  isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol,
 
   --------------------------------
   -- Builders
@@ -335,12 +335,10 @@ data SkolemInfo
 
   | RuleSkol RuleName  -- The LHS of a RULE
   | GenSkol TcType     -- Bound when doing a subsumption check for ty
+
   | RuntimeUnkSkol      -- a type variable used to represent an unknown
                         -- runtime type (used in the GHCi debugger)
 
-  | NoScSkol           -- Used for the "self" superclass when solving
-                       -- superclasses; don't generate superclasses of me
-
   | UnkSkol            -- Unhelpful info (until I improve it)
 
 -------------------------------------
@@ -450,6 +448,9 @@ pprSkolTvBinding tv
                                   sep [pprSkolInfo info, 
                                        nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]]
  
+instance Outputable SkolemInfo where
+  ppr = pprSkolInfo
+
 pprSkolInfo :: SkolemInfo -> SDoc
 -- Complete the sentence "is a rigid type variable bound by..."
 pprSkolInfo (SigSkol ctxt)  = pprUserTypeCtxt ctxt
@@ -457,7 +458,6 @@ pprSkolInfo (IPSkol ips)    = ptext (sLit "the implicit-parameter bindings for")
                               <+> pprWithCommas ppr ips
 pprSkolInfo (ClsSkol cls)   = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
 pprSkolInfo InstSkol        = ptext (sLit "the instance declaration")
-pprSkolInfo NoScSkol        = ptext (sLit "the instance declaration (self)")
 pprSkolInfo FamInstSkol     = ptext (sLit "the family instance declaration")
 pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
 pprSkolInfo ArrowSkol       = ptext (sLit "the arrow form")
@@ -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 )
@@ -670,15 +673,17 @@ isFlexi _     = False
 isIndirect (Indirect _) = True
 isIndirect _            = False
 
-isRuntimeUnk :: TyVar -> Bool
-isRuntimeUnk x | isTcTyVar x
-               , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
-               | otherwise = False
-
-isUnk :: TyVar -> Bool
-isUnk x | isTcTyVar x
-        , SkolemTv UnkSkol <- tcTyVarDetails x = True
-        | otherwise = False
+isRuntimeUnkSkol :: TyVar -> Bool
+-- Called only in TcErrors; see Note [Runtime skolems] there
+isRuntimeUnkSkol x | isTcTyVar x
+                  , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x 
+                  = True
+                  | otherwise = False
+
+isUnkSkol :: TyVar -> Bool
+isUnkSkol x | isTcTyVar x
+            , SkolemTv UnkSkol <- tcTyVarDetails x = True
+            | otherwise = False
 \end{code}
 
 
@@ -914,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  
@@ -951,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]
@@ -1019,8 +1028,6 @@ getClassPredTys _ = panic "getClassPredTys"
 mkDictTy :: Class -> [Type] -> Type
 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 
-
-
 isDictLikeTy :: Type -> Bool
 -- Note [Dictionary-like types]
 isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'