RHS of a type instance must be a tau type

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index ae90ef8..56ff0e1 100644 (file)
--- 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))
@@ -314,7 +318,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                 case new_or_data of
                   DataType -> return (mkDataTyConRhs data_cons)
                   NewType  -> ASSERT( isSingleton data_cons )
-                              mkNewTyConRhs tc_name tycon (head data_cons)
+                              mkNewTyConRhs rep_tc_name tycon (head data_cons)
             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
                             False h98_syntax (Just (family, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
@@ -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)
@@ -568,7 +572,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
     kc_con_details (RecCon fields) 
        = do { fields' <- mappM kc_field fields; return (RecCon fields') }
 
-    kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
+    kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
+                                          ; return (ConDeclField fld bty' d) }
 
     kc_larg_ty bty = case new_or_data of
                        DataType -> kcHsSigType bty
@@ -657,10 +662,11 @@ tcTyClDecl1 calc_isrec
   ; want_generic <- doptM Opt_Generics
   ; unbox_strict <- doptM Opt_UnboxStrictFields
   ; gla_exts     <- doptM Opt_GlasgowExts
+  ; gadt_ok      <- doptM Opt_GADTs
   ; is_boot     <- tcIsHsBoot  -- Are we compiling an hs-boot file?
 
        -- Check that we don't use GADT syntax in H98 world
-  ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+  ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
 
        -- Check that we don't use kind signatures without Glasgow extensions
   ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name)
@@ -775,8 +781,8 @@ tcConDecl unbox_strict tycon tc_tvs -- Data types
        InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
        RecCon fields      -> tc_datacon False field_names btys
                           where
-                             (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] 
-                              
+                             field_names = map cd_fld_name fields
+                             btys        = map cd_fld_type fields
     }
 
 tcResultType :: TyCon
@@ -1008,6 +1014,9 @@ checkNewDataCon con
                -- Return type is (T a b c)
        ; checkTc (null ex_tvs && null theta) (newtypeExError con)
                -- No existentials
+       ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) 
+                 (newtypeStrictError con)
+               -- No strictness
     }
   where
     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
@@ -1139,7 +1148,7 @@ badDataConTyCon data_con
 
 badGadtDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
-        , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
+        , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ]
 
 badStupidTheta tc_name
   = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
@@ -1152,6 +1161,10 @@ newtypeExError con
   = sep [ptext SLIT("A newtype constructor cannot have an existential context,"),
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")]
 
+newtypeStrictError con
+  = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"),
+        nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")]
+
 newtypePredError con
   = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"),
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")]
@@ -1168,7 +1181,7 @@ badSigTyDecl tc_name
 badFamInstDecl tc_name
   = vcat [ ptext SLIT("Illegal family instance for") <+>
           quotes (ppr tc_name)
-        , nest 2 (parens $ ptext SLIT("Use -ftype-families to allow indexed type families")) ]
+        , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ]
 
 badGadtIdxTyDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>
@@ -1194,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)")]