From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:40:13 +0000 (+0000) Subject: Check category of type instances and some newtype family fixes X-Git-Tag: After_FC_branch_merge~20 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d5c4754dcb857be7b9f4dbf6482e6050a9cd0991 Check category of type instances and some newtype family fixes Mon Sep 18 19:23:39 EDT 2006 Manuel M T Chakravarty * Check category of type instances and some newtype family fixes Thu Aug 31 16:54:14 EDT 2006 Manuel M T Chakravarty * Check category of type instances and some newtype family fixes --- diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e83d77f..278ffe8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -51,7 +51,8 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind, setTyConArgPoss ) + isNewTyCon, isDataTyCon, tyConKind, + setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -61,12 +62,12 @@ import Name ( Name, getSrcLoc ) import Outputable import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) +import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition, elemIndex ) import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) import ListSetOps ( equivClasses, minusList ) -import List ( delete ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) @@ -270,8 +271,12 @@ tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind _ -> - do { -- (1) kind check the right hand side of the type equation + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + unless (isSynTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind -- (2) type check type equation @@ -287,7 +292,12 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> - do { -- (1) kind check the data declaration as usual + do { -- check that the family declaration is for the right kind + unless (new_or_data == NewType && isNewTyCon family || + new_or_data == DataType && isDataTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs ; let k_ctxt = tcdCtxt k_decl k_cons = tcdCons k_decl @@ -1164,7 +1174,16 @@ tooFewParmsErr tc_name = ptext SLIT("Indexed type instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +badBootTyIdxDeclErr = + ptext SLIT("Illegal indexed type instance in hs-boot file") + +wrongKindOfFamily family = + ptext SLIT("Wrong category of type instance; declaration was for a") <+> + kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") + | isDataTyCon family = ptext SLIT("data type") + | isNewTyCon family = ptext SLIT("newtype") emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 86d4a2b..f16d89e 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -23,7 +23,8 @@ import Type ( predTypeRep, tcView ) import HscTypes ( TyThing(..), ModDetails(..) ) import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars, isSynTyCon, isAlgTyCon, - tyConName, isNewTyCon, isProductTyCon, newTyConRhs ) + tyConName, isNewTyCon, isProductTyCon, newTyConRhs, + isOpenTyCon ) import Class ( classTyCon ) import DataCon ( dataConOrigArgTys ) import Var ( TyVar ) @@ -238,7 +239,8 @@ calcRecFlags boot_details tyclss -- rather less nice, so I'm not going to do that yet. --------------- Newtypes ---------------------- - new_tycons = filter isNewTyCon all_tycons + new_tycons = filter isNewTyConAndNotOpen all_tycons + isNewTyConAndNotOpen tycon = isNewTyCon tycon && not (isOpenTyCon tycon) nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges) is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers -- is_rec_nt is a locally-used helper function diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 15be3e2..d536f59 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -550,13 +550,15 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) OpenNewTyCon -> False NewTyCon {} -> False AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) - isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of + OpenNewTyCon -> True + NewTyCon {} -> True + _ -> False +isNewTyCon other = False isProductTyCon :: TyCon -> Bool -- A "product" tycon @@ -746,7 +748,10 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) newTyConCo :: TyCon -> Maybe TyCon -newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co +newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) + = co +newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon}) + = Nothing newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon) tyConPrimRep :: TyCon -> PrimRep diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index a7aeeec..b7f1a00 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -117,7 +117,8 @@ import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, + isFunTyCon, isNewTyCon, isOpenTyCon, newTyConRep, + newTyConRhs, isAlgTyCon, tyConArity, isSuperKindTyCon, tcExpandTyCon_maybe, coreExpandTyCon_maybe, tyConKind, PrimRep(..), tyConPrimRep, tyConUnique, @@ -448,7 +449,7 @@ repType looks through (b) synonyms (c) predicates (d) usage annotations - (e) all newtypes, including recursive ones + (e) all newtypes, including recursive ones, but not newtype families It's useful in the back end. \begin{code} @@ -457,7 +458,8 @@ repType :: Type -> Type repType ty | Just ty' <- coreView ty = repType ty' repType (ForAllTy _ ty) = repType ty repType (TyConApp tc tys) - | isNewTyCon tc = -- Recursive newtypes are opaque to coreView + | isNewTyCon tc && + not (isOpenTyCon tc) = -- Recursive newtypes are opaque to coreView -- but we must expand them here. Sure to -- be saturated because repType is only applied -- to types of kind *