X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=834bedcc3352b1f8bf5e9f1c22f87d585ec403cf;hb=f8f8449e1e54d0da1d16536070f18709b9e95af4;hp=ffa03fed6e7509b6d60f1d3edc27b72d1184f55c;hpb=4b922606a68ee6402803b217ea899e9dd7f12f9b;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ffa03fe..834bedc 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[TcTyClsDecls]{Typecheck type and class declarations} + +TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( @@ -10,70 +12,39 @@ module TcTyClsDecls ( #include "HsVersions.h" -import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isIdxTyDecl, - isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType - ) -import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) -import BasicTypes ( RecFlag(..), StrictnessMark(..) ) -import HscTypes ( implicitTyThings, ModDetails ) -import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, - mkDataTyConRhs, mkNewTyConRhs ) +import HsSyn +import HsTypes +import BasicTypes +import HscTypes +import BuildTyCl import TcRnMonad -import TcEnv ( TyThing(..), - tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, - tcExtendKindEnvTvs, newFamInstTyConName, - tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon ) -import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) -import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, - kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConResTy, - tcDataKindSig, kcCheckHsType ) -import TcMType ( newKindVar, checkValidTheta, checkValidType, - -- checkFreeness, - UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy, - mkArrowKind, liftedTypeKind, - tcSplitSigmaTy, tcGetTyVar_maybe ) -import Type ( splitTyConApp_maybe, - newTyConInstRhs, isLiftedTypeKind, Kind, - splitKindFunTys, mkArrowKinds - -- pprParendType, pprThetaArrow - ) -import Generics ( validGenericMethodType, canDoGenerics ) -import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, - OpenNewTyCon ), - SynTyConRhs( OpenSynTyCon, SynonymTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, - isRecursiveTyCon, - tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, isDataTyCon, tyConKind, - setTyConArgPoss ) -import DataCon ( DataCon, dataConUserType, dataConName, - dataConFieldLabels, dataConTyCon, dataConAllTyVars, - dataConFieldType, dataConResTys ) -import Var ( TyVar, idType, idName, tyVarName, setTyVarName ) -import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name, getSrcLoc, tidyNameOcc, getOccName ) -import OccName ( initTidyOccEnv, tidyOccName ) +import TcEnv +import TcTyDecls +import TcClassDcl +import TcHsType +import TcMType +import TcType +import FunDeps +import Type +import Generics +import Class +import TyCon +import DataCon +import Var +import VarSet +import Name +import OccName import Outputable -import Maybe ( isJust, fromJust, isNothing, catMaybes ) -import Maybes ( expectJust ) -import Monad ( unless ) -import Unify ( tcMatchTys, tcMatchTyX ) -import Util ( zipLazy, isSingleton, notNull, sortLe, mapAccumL ) -import List ( partition, elemIndex ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, - srcSpanStart ) -import ListSetOps ( equivClasses, minusList ) -import Digraph ( SCC(..) ) -import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields, Opt_IndexedTypes ) ) +import Maybes +import Monad +import Unify +import Util +import SrcLoc +import ListSetOps +import Digraph +import DynFlags + +import Data.List ( partition, elemIndex ) \end{code} @@ -196,6 +167,7 @@ tcTyAndClassDecls boot_details allDecls ; let { -- Calculate rec-flag ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_rec) } + -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls kc_syn_decls ; tcExtendGlobalEnv syn_tycons $ do @@ -379,7 +351,7 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckHsType hs_typats kinds + ; typats <- TcRnMonad.zipWithM kcCheckHsType hs_typats kinds ; thing_inside tvs typats resultKind family } where @@ -572,14 +544,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; cons' <- mappM (wrapLocM kc_con_decl) cons ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do + -- doc comments are typechecked to Nothing here + kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do kcHsTyVars ex_tvs $ \ex_tvs' -> do ex_ctxt' <- kcHsContext ex_ctxt details' <- kc_con_details details res' <- case res of ResTyH98 -> return ResTyH98 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - return (ConDecl name expl ex_tvs' ex_ctxt' details' res') + return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) kc_con_details (PrefixCon btys) = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } @@ -588,7 +561,7 @@ 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 (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } + kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) } kc_larg_ty bty = case new_or_data of DataType -> kcHsSigType bty @@ -769,7 +742,7 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> TcM DataCon tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes - (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) + (ConDecl name _ ex_tvs ex_ctxt details ResTyH98 _) = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype ; buildDataCon (unLoc name) False {- Prefix -} @@ -785,14 +758,14 @@ tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes ; case details of PrefixCon [arg_ty] -> tc_datacon [] arg_ty - RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty + RecCon [HsRecField field_lbl arg_ty _] -> tc_datacon [field_lbl] arg_ty other -> failWithTc (newtypeFieldErr name (length (hsConArgs details))) -- Check that the constructor has exactly one field } tcConDecl unbox_strict DataType tycon tc_tvs -- Data types - (ConDecl name _ tvs ctxt details res_ty) + (ConDecl name _ tvs ctxt details res_ty _) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty @@ -802,7 +775,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types = do { let bangs = map getBangStrictness btys ; arg_tys <- mappM tcHsBangType btys ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict tycon bangs arg_tys) + (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys data_tc } @@ -815,7 +788,7 @@ tcConDecl unbox_strict DataType 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 fields + (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] } @@ -876,11 +849,11 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) ------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields - -> TyCon -> [HsBang] + -> [HsBang] -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict tycon bangs arg_tys +argStrictness unbox_strict bangs arg_tys = ASSERT( length bangs == length arg_tys ) - zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs + zipWith (chooseBoxingStrategy unbox_strict) arg_tys bangs -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -888,8 +861,8 @@ argStrictness unbox_strict tycon bangs arg_tys -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of HsNoBang -> NotMarkedStrict HsStrict | unbox_strict_fields @@ -902,13 +875,21 @@ chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang can_unbox arg_ty = case splitTyConApp_maybe arg_ty of Nothing -> False Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon tycon) && + not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] isProductTyCon arg_tycon && (if isNewTyCon arg_tycon then can_unbox (newTyConInstRhs arg_tycon tycon_args) else True) \end{code} +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful not to try to unbox this! + data T = MkT !T Int +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + %************************************************************************ %* * \subsection{Dependency analysis} @@ -1063,8 +1044,13 @@ checkValidClass cls ; checkValidType (FunSigCtxt op_name) tau -- Check that the type mentions at least one of - -- the class type variables - ; checkTc (any (`elemVarSet` tyVarsOfType tau) tyvars) + -- the class type variables...or at least one reachable + -- from one of the class variables. Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + ; let grown_tyvars = grow theta (mkVarSet tyvars) + ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) -- Check that for a generic method, the type of @@ -1170,7 +1156,7 @@ newtypeFieldErr con_name n_flds badSigTyDecl tc_name = vcat [ ptext SLIT("Illegal kind signature") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] + , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ] badKindSigCtxt tc_name = vcat [ ptext SLIT("Illegal context in kind signature") <+> @@ -1180,7 +1166,7 @@ badKindSigCtxt tc_name badIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal indexed type instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow indexed types")) ] + , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ] badGadtIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>