X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=3fec58dd0a402b6d98daa0bc0e4f6b5518ca10e8;hb=1cdafe99abae1628f34ca8c064e3a8c0fcdbd079;hp=432d3c8caed2e0141b652be2ccd6ffea6df16354;hpb=958924a2b338aebbcc8a88ba2cab511517762a19;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 432d3c8..3fec58d 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -13,7 +13,8 @@ import TcBinds		( mkPragFun, tcPrags, badBootDeclErr )
 import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr, 
 			  tcClassDecl2, getGenericInstances )
 import TcRnMonad       
-import TcMType		( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, 
+import TcMType		( tcSkolSigType, checkValidTheta, checkValidInstHead,
+			  checkInstTermination, instTypeErr, 
 			  checkAmbiguity, SourceTyCtxt(..) )
 import TcType		( mkClassPred, tyVarsOfType, 
 			  tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
@@ -35,7 +36,6 @@ import Var		( Id, idName, idType )
 import MkId		( mkDictFunId, rUNTIME_ERROR_ID )
 import FunDeps		( checkInstFDs )
 import Name		( Name, getSrcLoc )
-import UnicodeUtil	( stringToUtf8 )
 import Maybe		( catMaybes )
 import SrcLoc		( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps	( minusList )
@@ -180,10 +180,6 @@ tcLocalInstDecl1 :: LInstDecl Name
 	-- Type-check all the stuff before the "where"
 	--
 	-- We check for respectable instance type, and context
-	-- but only do this for non-imported instance decls.
-	-- Imported ones should have been checked already, and may indeed
-	-- contain something illegal in normal Haskell, notably
-	--	instance CCallable [Char] 
 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
   =	-- Prime error recovery, set source location
     recoverM (returnM Nothing)		$
@@ -200,6 +196,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
     checkValidTheta InstThetaCtxt theta			`thenM_`
     checkAmbiguity tyvars theta (tyVarsOfType tau)	`thenM_`
     checkValidInstHead tau				`thenM` \ (clas,inst_tys) ->
+    checkInstTermination theta inst_tys			`thenM_`
     checkTc (checkInstFDs theta clas inst_tys)
 	    (instTypeErr (pprClassPred clas inst_tys) msg)	`thenM_`
     newDFunName clas inst_tys (srcSpanStart loc)		`thenM` \ dfun_name ->
@@ -396,18 +393,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 		--	See Note [Inline dfuns] below
 
 	dict_rhs
-	  | null scs_and_meths
-	  = 	-- Blatant special case for CCallable, CReturnable
-		-- If the dictionary is empty then we should never
-		-- select anything from it, so we make its RHS just
-		-- emit an error message.  This in turn means that we don't
-		-- mention the constructor, which doesn't exist for CCallable, CReturnable
-		-- Hardly beautiful, but only three extra lines.
-	    nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID) 
-				   [idType this_dict_id])
-		  (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
-
-	  | otherwise	-- The common case
 	  = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
 		-- We don't produce a binding for the dict_constr; instead we
 		-- rely on the simplifier to unfold this saturated application