Fix Trac #4841: behave right with TypeSynonymInstances and NoFlexibleInstances

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

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index b49dbff..50ac35a 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
@@ -123,7 +123,8 @@ module TcType (
   -- Type substitutions
   TvSubst(..),         -- Representation visible to a few friends
   TvSubstEnv, emptyTvSubst, substEqSpec,
-  mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
+  mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, 
+  mkTopTvSubst, notElemTvSubst, unionTvSubst,
   getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
   extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
   substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
@@ -302,6 +303,11 @@ data MetaInfo
                   -- The Name is the name of the function from whose
                   -- type signature we got this skolem
 
+   | TcsTv        -- A MetaTv allocated by the constraint solver
+                  -- Its particular property is that it is always "touchable"
+                  -- Nevertheless, the constraint solver has to try to guess
+                  -- what type to instantiate it to
+
 ----------------------------------
 -- SkolemInfo describes a site where 
 --   a) type variables are skolemised
@@ -329,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)
 
 -------------------------------------
@@ -408,6 +412,7 @@ pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 pprTcTyVarDetails (SkolemTv _)         = ptext (sLit "sk")
 pprTcTyVarDetails (FlatSkol {})        = ptext (sLit "fsk")
 pprTcTyVarDetails (MetaTv TauTv _)     = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv TcsTv _)     = ptext (sLit "tcs")
 pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
 
 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
@@ -433,8 +438,9 @@ pprSkolTvBinding tv
   where
     ppr_details (SkolemTv info)      = ppr_skol info
     ppr_details (FlatSkol {})       = ptext (sLit "is a flattening type variable")
-    ppr_details (MetaTv TauTv _)     = ptext (sLit "is a meta type variable")
-    ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") <+> quotes (ppr n)
+    ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
+                                       <+> quotes (ppr n)
+    ppr_details (MetaTv _ _)         = ptext (sLit "is a meta type variable")
 
     ppr_skol UnkSkol       = ptext (sLit "is an unknown type variable")        -- Unhelpful
     ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
@@ -442,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
@@ -449,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")
@@ -606,7 +614,7 @@ isImmutableTyVar tv
   | isTcTyVar tv = isSkolemTyVar tv
   | otherwise    = True
 
-isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, 
+isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
   isMetaTyVar :: TcTyVar -> Bool 
 
 isTyConableTyVar tv    
@@ -615,8 +623,8 @@ isTyConableTyVar tv
        -- not a SigTv
   = ASSERT( isTcTyVar tv) 
     case tcTyVarDetails tv of
-       MetaTv TauTv _ -> True
-       _              -> False
+       MetaTv (SigTv _) _ -> False
+       _                  -> True
        
 isSkolemTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
@@ -625,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 )
@@ -662,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}
 
 
@@ -943,6 +956,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]
@@ -1011,8 +1027,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'