Fix check of rhs of type family instances (#2157)

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

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 865c749..fc620ec 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -179,7 +179,7 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
 --    (checkTauTvUpdate tv ty)
 -- We are about to update the TauTv tv with ty.
 -- Check (a) that tv doesn't occur in ty (occurs check)
---      (b) that ty is a monotype
+--       (b) that ty is a monotype
 -- Furthermore, in the interest of (b), if you find an
 -- empty box (BoxTv that is Flexi), fill it in with a TauTv
 -- 
@@ -218,7 +218,7 @@ checkTauTvUpdate orig_tv orig_ty
        | isSynTyCon tc  = go_syn tc tys
        | otherwise      = do { tys' <- mapM go tys
                               ; return $ occurs (TyConApp tc) tys' }
-    go (PredTy p)       = do { p' <- go_pred p
+    go (PredTy p)            = do { p' <- go_pred p
                               ; return $ occurs1 PredTy p' }
     go (FunTy arg res)   = do { arg' <- go arg
                               ; res' <- go res
@@ -1054,7 +1054,7 @@ nonZeroRank _        = True
 
 ----------------------------------------
 data UbxTupFlag = UT_Ok        | UT_NotOk
-       -- The "Ok" version means "ok if -fglasgow-exts is on"
+       -- The "Ok" version means "ok if UnboxedTuples is on"
 
 ----------------------------------------
 check_mono_type :: Type -> TcM ()      -- No foralls anywhere
@@ -1681,8 +1681,7 @@ checkValidTypeInst typats rhs
        ; mapM_ checkTyFamFreeness typats
 
          -- the right-hand side is a tau type
-       ; checkTc (isTauTy rhs) $ 
-          polyTyErr rhs
+       ; checkValidMonoType rhs
 
          -- we have a decidable instance unless otherwise permitted
        ; undecidable_ok <- doptM Opt_UndecidableInstances
@@ -1735,11 +1734,6 @@ tyFamInstInIndexErr ty
          colon) 4 $
       ppr ty
 
-polyTyErr :: Type -> SDoc
-polyTyErr ty 
-  = hang (ptext (sLit "Illegal polymorphic type in type instance") <> colon) 4 $
-      ppr ty
-
 famInstUndecErr :: Type -> SDoc -> SDoc
 famInstUndecErr ty msg 
   = sep [msg,