Fix typo

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 04fbafb..45338d0 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -13,11 +13,9 @@ import TcBinds               ( mkPragFun, tcPrags, badBootDeclErr )
 import TcClassDcl      ( tcMethodBind, mkMethodBind, badMethodErr, 
                          tcClassDecl2, getGenericInstances )
 import TcRnMonad       
-import TcMType         ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, 
-                         checkAmbiguity, SourceTyCtxt(..) )
-import TcType          ( mkClassPred, tyVarsOfType, 
-                         tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
-                         SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
+import TcMType         ( tcSkolSigType, checkValidInstance, checkValidInstHead )
+import TcType          ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
+                         SkolemInfo(InstSkol), tcSplitDFunTy )
 import Inst            ( tcInstClassOp, newDicts, instToId, showLIE, 
                          getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv         ( mkLocalInstance, instanceDFunId )
@@ -32,8 +30,7 @@ import Type           ( zipOpenTvSubst, substTheta, substTys )
 import DataCon         ( classDataCon )
 import Class           ( classBigSig )
 import Var             ( Id, idName, idType )
-import MkId            ( mkDictFunId, rUNTIME_ERROR_ID )
-import FunDeps         ( checkInstFDs )
+import MkId            ( mkDictFunId )
 import Name            ( Name, getSrcLoc )
 import Maybe           ( catMaybes )
 import SrcLoc          ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
@@ -179,41 +176,31 @@ 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)         $
     setSrcSpan loc                     $
     addErrCtxt (instDeclCtxt1 poly_ty) $
 
+    do { is_boot <- tcIsHsBoot
+       ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+                 badBootDeclErr
+
        -- Typecheck the instance type itself.  We can't use 
        -- tcHsSigType, because it's not a valid user type.
-    kcHsSigType poly_ty                        `thenM` \ kinded_ty ->
-    tcHsKindedType kinded_ty           `thenM` \ poly_ty' ->
-    let
-       (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
-    in
-    checkValidTheta InstThetaCtxt theta                        `thenM_`
-    checkAmbiguity tyvars theta (tyVarsOfType tau)     `thenM_`
-    checkValidInstHead tau                             `thenM` \ (clas,inst_tys) ->
-    checkTc (checkInstFDs theta clas inst_tys)
-           (instTypeErr (pprClassPred clas inst_tys) msg)      `thenM_`
-    newDFunName clas inst_tys (srcSpanStart loc)               `thenM` \ dfun_name ->
-    getOverlapFlag                                             `thenM` \ overlap_flag ->
-    let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
-       ispec = mkLocalInstance dfun overlap_flag
-    in
-
-    tcIsHsBoot                                         `thenM` \ is_boot ->
-    checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
-           badBootDeclErr                              `thenM_`
-
-    returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags }))
-  where
-    msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
+       ; kinded_ty <- kcHsSigType poly_ty
+       ; poly_ty'  <- tcHsKindedType kinded_ty
+       ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+       
+       ; (clas, inst_tys) <- checkValidInstHead tau
+       ; checkValidInstance tyvars theta clas inst_tys
+
+       ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
+       ; overlap_flag <- getOverlapFlag
+       ; let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
+             ispec = mkLocalInstance dfun overlap_flag
+
+       ; return (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) }
 \end{code}
 
 
@@ -395,18 +382,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
@@ -415,9 +390,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
                -- member) are dealt with by the common MkId.mkDataConWrapId code rather
                -- than needing to be repeated here.
 
-         where
-           msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
-
        dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
        all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)