[project @ 1996-07-25 20:43:49 by partain]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index cef6f6a..5194f9e 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -21,31 +21,32 @@ import HsSyn                ( InstDecl(..), FixityDecl, Sig(..),
                          InPat(..), OutPat(..), HsExpr(..), HsLit(..),
                          Stmt, Qualifier, ArithSeqInfo, Fake,
                          PolyType(..), MonoType )
-import RnHsSyn         ( RenamedHsBinds(..), RenamedMonoBinds(..),
+import RnHsSyn         ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
                          RenamedInstDecl(..), RenamedFixityDecl(..),
                          RenamedSig(..), RenamedSpecInstSig(..),
                          RnName(..){-incl instance Outputable-}
                        )
-import TcHsSyn         ( TcIdOcc(..), TcHsBinds(..),
-                         TcMonoBinds(..), TcExpr(..), tcIdType,
+import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcHsBinds),
+                         SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 
 
 import TcMonad         hiding ( rnMtoTcM )
 import GenSpecEtc      ( checkSigTyVars )
-import Inst            ( Inst, InstOrigin(..), InstanceMapper(..),
-                         newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import Inst            ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
+                         newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
 import TcBinds         ( tcPragmaSigs )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import SpecEnv         ( SpecEnv )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind          ( TcKind, unifyKind )
 import TcMatches       ( tcMatchesFun )
 import TcMonoType      ( tcContext, tcMonoTypeKind )
 import TcSimplify      ( tcSimplifyAndCheck )
-import TcType          ( TcType(..), TcTyVar(..), TcTyVarSet(..), 
+import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), 
                          tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
                        )
 import Unify           ( unifyTauTy, unifyTauTyLists )
@@ -60,7 +61,7 @@ import CmdLineOpts    ( opt_GlasgowExts, opt_CompilingGhcInternals,
 import Class           ( GenClass, GenClassOp, 
                          isCcallishClass, classBigSig,
                          classOps, classOpLocalType,
-                         classOpTagByString
+                         classOpTagByString_maybe
                          )
 import Id              ( GenId, idType, isDefaultMethodId_maybe )
 import ListSetOps      ( minusList )
@@ -79,7 +80,7 @@ import Type           ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
                          splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
                          getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
                        )
-import TyVar           ( GenTyVar, GenTyVarSet(..), mkTyVarSet, unionTyVarSets )
+import TyVar           ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique )
 import Util            ( zipEqual, panic )
@@ -601,10 +602,13 @@ processInstBinds1 clas avail_insts method_ids mbind
 
     -- Make a method id for the method
     let
-       tag       = classOpTagByString clas occ
-       method_id = method_ids !! (tag-1)
-       method_ty = tcIdType method_id
+       maybe_tag  = classOpTagByString_maybe clas occ
+       (Just tag) = maybe_tag
+       method_id  = method_ids !! (tag-1)
+       method_ty  = tcIdType method_id
     in
+    -- check that the method mentioned is actually in the class:
+    checkMaybeTc maybe_tag (instMethodNotInClassErr occ clas) `thenTc_`
 
     tcInstTcType method_ty             `thenNF_Tc` \ (method_tyvars, method_rho) ->
     let
@@ -631,7 +635,7 @@ processInstBinds1 clas avail_insts method_ids mbind
                -- Make the method_tyvars into signature tyvars so they
                -- won't get unified with anything.
        tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
-       unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys        `thenTc_`
+       unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)        `thenTc_`
 
        newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
        newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
@@ -920,6 +924,10 @@ omitDefaultMethodWarn clas_op clas_name inst_ty sty
           ppr sty clas_op, ppStr "in instance",
           ppPStr clas_name, pprParendGenType sty inst_ty]
 
+instMethodNotInClassErr occ clas sty
+  = ppHang (ppStr "Instance mentions a method not in the class")
+        4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
+                      ppPStr occ, ppStr "'"])
 
 patMonoBindsCtxt pbind sty
   = ppHang (ppStr "In a pattern binding:")