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 04fbafb..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,
@@ -179,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)         $
@@ -199,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 ->
@@ -395,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 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