X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=56ff0e1bca581364956792b3b1b5cb60da3256cd;hp=191e546eeb01b14d01ac5bb74299e16ed0a07bd9;hb=485c8034041b7d7f26688c24b88a50a62e3d3229;hpb=5a3ada9ce8887154faf81954b8b45dbb882fe264

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 191e546..56ff0e1 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -259,7 +259,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
 	 unless (isSynTyCon family) $
 	   addErr (wrongKindOfFamily family)
 
-       ; -- (1) kind check the right hand side of the type equation
+       ; -- (1) kind check the right-hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
          -- (2) type check type equation
@@ -267,7 +267,11 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
-         -- (3) construct representation tycon
+       ; -- (3) check that the right-hand side is a tau type
+       ; unless (isTauTy t_rhs) $
+	   addErr (polyTyErr t_rhs)
+
+         -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name loc
        ; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
                                 (Just (family, t_typats))
@@ -339,7 +343,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 --
 -- * Here we check that a type instance matches its kind signature, but we do
 --   not check whether there is a pattern for each type index; the latter
---   check is only required for type functions.
+--   check is only required for type synonym instances.
 --
 kcIdxTyPats :: TyClDecl Name
 	    -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
@@ -1203,6 +1207,10 @@ wrongKindOfFamily family =
 		 | isAlgTyCon family = ptext SLIT("data type")
 		 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 
+polyTyErr ty 
+  = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $
+      ppr ty
+
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 	 nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]