relaxed instance termination test

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 432d3c8..3fec58d 100644 (file)
--- 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