From ab8279d659dd0fccd8738735c11f8a0767505570 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 18 May 1999 14:55:48 +0000 Subject: [PATCH] [project @ 1999-05-18 14:55:47 by simonpj] msg_tc --- ghc/compiler/typecheck/TcClassDcl.lhs | 121 ++++++++++++++++----------------- ghc/compiler/typecheck/TcInstDcls.lhs | 61 ++++++++--------- ghc/compiler/typecheck/TcMonoType.lhs | 49 ++++++------- 3 files changed, 112 insertions(+), 119 deletions(-) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index e8e9bc3..721ea2a 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,7 +4,9 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where +module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, + tcMethodBind, checkFromThisClass + ) where #include "HsVersions.h" @@ -12,10 +14,10 @@ import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), HsExpr(..), HsLit(..), HsType(..), pprClassAssertion, unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName, - isClassDecl, isClassOpSig + isClassDecl, isClassOpSig, collectMonoBinders ) import HsPragmas ( ClassPragmas(..) ) -import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) ) +import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas, RenamedClassOpSig, RenamedMonoBinds, RenamedContext, RenamedHsDecl, RenamedSig @@ -27,7 +29,7 @@ import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv ) -import TcBinds ( tcBindWithSigs, tcPragmaSigs ) +import TcBinds ( tcBindWithSigs, tcSpecSigs ) import TcUnify ( unifyKinds ) import TcMonad import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, @@ -35,21 +37,20 @@ import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar ) -import PrelVals ( nO_METHOD_BINDING_ERROR_ID ) +import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import FieldLabel ( firstFieldLabelTag ) -import Bag ( unionManyBags ) +import Bag ( unionManyBags, bagToList ) import Class ( mkClass, classBigSig, Class ) import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) -import MkId ( mkSuperDictSelId, mkDataConId, - mkMethodSelId, mkDefaultMethodId - ) -import DataCon ( mkDataCon ) +import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId ) +import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, getIdUnfolding, idType, idName ) import CoreUnfold ( getUnfoldingTemplate ) import IdInfo -import Name ( Name, isLocallyDefined, NamedThing(..) ) +import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) ) +import NameSet ( emptyNameSet ) import Outputable import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkSigmaTy, mkForAllTys, Type, ThetaType, @@ -62,12 +63,6 @@ import Unique ( Unique, Uniquable(..) ) import Util import Maybes ( seqMaybe ) import FiniteMap ( lookupWithDefaultFM ) - - --- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) -tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo, - noIdInfo) \end{code} @@ -114,7 +109,7 @@ Death to "ExpandingDicts". \begin{code} kcClassDecl (ClassDecl context class_name tyvar_names class_sigs def_methods pragmas - tycon_name datacon_name src_loc) + tycon_name datacon_name sc_sel_names src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 checkTc (opt_GlasgowExts || length tyvar_names == 1) (classArityErr class_name) `thenTc_` @@ -146,7 +141,7 @@ kcClassDecl (ClassDecl context class_name tcClassDecl1 rec_env rec_inst_mapper rec_vrcs (ClassDecl context class_name tyvar_names class_sigs def_methods pragmas - tycon_name datacon_name src_loc) + tycon_name datacon_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ -> @@ -154,7 +149,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs -- CHECK THE CONTEXT -- traceTc (text "tcClassCtxt" <+> ppr class_name) `thenTc_` - tcClassContext class_name rec_class tyvars context pragmas + tcClassContext class_name rec_class tyvars context sc_sel_names `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_` @@ -178,7 +173,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs other -> DataType dict_con = mkDataCon datacon_name - [NotMarkedStrict | _ <- dict_component_tys] + [notMarkedStrict | _ <- dict_component_tys] [{- No labelled fields -}] tyvars [{-No context-}] @@ -209,12 +204,12 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs \begin{code} tcClassContext :: Name -> Class -> [TyVar] -> RenamedContext -- class context - -> RenamedClassPragmas -- pragmas for superclasses + -> [Name] -- Names for superclass selectors -> TcM s (ThetaType, -- the superclass context [Type], -- types of the superclass dictionaries [Id]) -- superclass selector Ids -tcClassContext class_name rec_class rec_tyvars context pragmas +tcClassContext class_name rec_class rec_tyvars context sc_sel_names = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. @@ -230,31 +225,19 @@ tcClassContext class_name rec_class rec_tyvars context pragmas let sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] + sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys in - - -- Make super-class selector ids - -- We number them off, 1, 2, 3 etc so that we can construct - -- names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids -> - -- Done returnTc (sc_theta, sc_tys, sc_sel_ids) where rec_tyvar_tys = mkTyVarTys rec_tyvars - mk_super_id ((super_class, tys), index) - = tcGetUnique `thenNF_Tc` \ uniq -> - let - ty = mkForAllTys rec_tyvars $ - mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys) - in - returnTc (mkSuperDictSelId uniq rec_class index ty) + mk_super_id name dict_ty + = mkDictSelId name rec_class ty + where + ty = mkForAllTys rec_tyvars $ + mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty check_constraint (c, tys) = checkTc (all is_tyvar tys) (superClassErr class_name (c, tys)) @@ -290,7 +273,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvars local_ty -- Build the selector id and default method id - sel_id = mkMethodSelId op_name rec_clas global_ty + sel_id = mkDictSelId op_name rec_clas global_ty maybe_dm_id = case maybe_dm_name of Nothing -> Nothing Just dm_name -> let @@ -347,7 +330,7 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> NF_TcM s (LIE, TcMonoBinds) tcClassDecl2 (ClassDecl context class_name - tyvar_names class_sigs default_binds pragmas _ _ src_loc) + tyvar_names class_sigs default_binds pragmas _ _ _ src_loc) | not (isLocallyDefined class_name) = returnNF_Tc (emptyLIE, EmptyMonoBinds) @@ -362,19 +345,15 @@ tcClassDecl2 (ClassDecl context class_name (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas -- The selector binds are already in the selector Id's unfoldings --- sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id)) --- | sel_id <- sc_sel_ids ++ op_sel_ids, --- isLocallyDefined sel_id --- ] --- --- final_sel_binds = andMonoBindList sel_binds + sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id)) + | sel_id <- sc_sel_ids ++ op_sel_ids + ] in -- Generate bindings for the default methods tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) -> - returnTc (const_insts, meth_binds) --- final_sel_binds `AndMonoBinds` meth_binds) --- Leave 'em out for now. They always get inlined anyway. SLPJ June '98 + returnTc (const_insts, + meth_binds `AndMonoBinds` andMonoBindList sel_binds) \end{code} %************************************************************************ @@ -458,7 +437,10 @@ tcDefaultMethodBinds tcDefaultMethodBinds clas default_binds = -- Construct suitable signatures - tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) -> + tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) -> + + -- Check that the default bindings come from this class + checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_` -- Typecheck the default bindings let @@ -497,6 +479,7 @@ tcDefaultMethodBinds clas default_binds clas_tyvars' [this_dict_id] abs_bind_stuff + emptyNameSet -- No inlines (yet) (dict_binds `andMonoBinds` andMonoBindList defm_binds) in returnTc (const_lie, full_binds) @@ -511,6 +494,21 @@ tcDefaultMethodBinds clas default_binds origin = ClassDeclOrigin \end{code} +\begin{code} +checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s () +checkFromThisClass clas op_sel_ids mono_binds + = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_` + returnNF_Tc () + where + check_from_this_class (bndr, loc) + | nameOccName bndr `elem` sel_names = returnNF_Tc () + | otherwise = tcAddSrcLoc loc $ + addErrTc (badMethodErr bndr clas) + sel_names = map getOccName op_sel_ids + bndrs = bagToList (collectMonoBinders mono_binds) +\end{code} + + @tcMethodBind@ is used to type-check both default-method and instance-decl method declarations. We must type-check methods one at a time, because their signatures may have different contexts and @@ -565,21 +563,20 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default) (omittedMethodWarn sel_id clas) `thenNF_Tc_` - -- Check the pragmas - tcExtendLocalValEnv [(meth_name, meth_id)] ( - tcPragmaSigs meth_prags - ) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) -> - -- Check the bindings; first add inst_tyvars to the envt -- so that we don't quantify over them in nested places -- The *caller* put the class/inst decl tyvars into the envt tcExtendGlobalTyVars (mkVarSet inst_tyvars) ( tcAddErrCtxt (methodCtxt sel_id) $ - tcBindWithSigs NotTopLevel meth_bind [sig_info] - NonRecursive prag_info_fn + tcBindWithSigs NotTopLevel meth_bind + [sig_info] meth_prags NonRecursive ) `thenTc` \ (binds, insts, _) -> + tcExtendLocalValEnv [(meth_name, meth_id)] ( + tcSpecSigs meth_prags + ) `thenTc` \ (prag_binds1, prag_lie) -> + -- The prag_lie for a SPECIALISE pragma will mention the function -- itself, so we have to simplify them away right now lest they float -- outwards! @@ -615,8 +612,8 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta -- Find the prags for this method, and replace the -- selector name with the method name find_prags meth_name [] = [] - find_prags meth_name (SpecSig name ty spec loc : prags) - | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags + find_prags meth_name (SpecSig name ty loc : prags) + | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags find_prags meth_name (InlineSig name loc : prags) | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags find_prags meth_name (NoInlineSig name loc : prags) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index d99f93d..3333d42 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -14,15 +14,15 @@ module TcInstDcls ( import HsSyn ( HsDecl(..), InstDecl(..), HsBinds(..), MonoBinds(..), HsExpr(..), InPat(..), HsLit(..), Sig(..), - collectMonoBinders, andMonoBindList + andMonoBindList ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl ) import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType ) -import TcBinds ( tcPragmaSigs ) -import TcClassDcl ( tcMethodBind, badMethodErr ) +import TcBinds ( tcSpecSigs ) +import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad import RnMonad ( RnNameSupply, Fixities ) import Inst ( Inst, InstOrigin(..), @@ -37,17 +37,18 @@ import TcSimplify ( tcSimplifyAndCheck ) import TcType ( TcTyVar, zonkTcTyVarBndr ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, - foldBag, bagToList, Bag + foldBag, Bag ) import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) import Class ( classBigSig, Class ) -import Var ( setIdInfo, idName, idType, Id, TyVar ) +import Var ( idName, idType, Id, TyVar ) import DataCon ( isNullaryDataCon, dataConArgTys, dataConId ) import Maybes ( maybeToBool, catMaybes, expectJust ) import MkId ( mkDictFunId ) -import Module ( Module ) -import Name ( nameOccName, isLocallyDefined, NamedThing(..) ) -import PrelVals ( eRROR_ID ) +import Module ( ModuleName ) +import Name ( isLocallyDefined, NamedThing(..) ) +import NameSet ( emptyNameSet ) +import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint ) import SrcLoc ( SrcLoc ) import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings ) @@ -55,9 +56,9 @@ import Type ( Type, isUnLiftedType, mkTyVarTys, splitSigmaTy, isTyVarTy, splitTyConApp_maybe, splitDictTy_maybe, unUsgTy, splitAlgTyConApp_maybe, - tyVarsOfTypes, substTopTheta + tyVarsOfTypes ) -import VarEnv ( zipVarEnv ) +import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( mkVarSet, varSetElems ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) @@ -141,7 +142,7 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \begin{code} tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] - -> Module -- module name for deriving + -> ModuleName -- module name for deriving -> Fixities -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, @@ -149,7 +150,7 @@ tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids tcInstDecls1 unf_env decls mod_name fixs rn_name_supply = -- Do the ordinary instance declarations - mapNF_Tc (tcInstDecl1 unf_env mod_name) + mapNF_Tc (tcInstDecl1 unf_env) [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags -> let decl_inst_info = unionManyBags inst_info_bags @@ -166,9 +167,9 @@ tcInstDecls1 unf_env decls mod_name fixs rn_name_supply returnTc (full_inst_info, deriv_binds) -tcInstDecl1 :: ValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) +tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) -tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc) +tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc emptyBag) $ tcAddSrcLoc src_loc $ @@ -194,7 +195,7 @@ tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src returnNF_Tc [] ) `thenNF_Tc_` - -- Make the dfun id and constant-method ids + -- Make the dfun id let dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta @@ -331,11 +332,11 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys op_sel_ids, defm_ids) = classBigSig clas -- Instantiate the theta found in the original instance decl - inst_decl_theta' = substTopTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars')) - inst_decl_theta + inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) + inst_decl_theta -- Instantiate the super-class context with inst_tys - sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys') sc_theta + sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta in -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> @@ -344,15 +345,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> -- Check that all the method bindings come from this class - let - check_from_this_class (bndr, loc) - | nameOccName bndr `elem` sel_names = returnNF_Tc () - | otherwise = tcAddSrcLoc loc $ - addErrTc (badMethodErr bndr clas) - sel_names = map getOccName op_sel_ids - bndrs = bagToList (collectMonoBinders monobinds) - in - mapNF_Tc check_from_this_class bndrs `thenNF_Tc_` + checkFromThisClass clas op_sel_ids monobinds `thenNF_Tc_` tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( tcExtendGlobalValEnv (catMaybes defm_ids) ( @@ -363,13 +356,14 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys (op_sel_ids `zip` defm_ids) )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> - -- Deal with SPECIALISE instance pragmas + -- Deal with SPECIALISE instance pragmas by making them + -- look like SPECIALISE pragmas for the dfun let - dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags] + dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags] in tcExtendGlobalValEnv [dfun_id] ( - tcPragmaSigs dfun_prags - ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> + tcSpecSigs dfun_prags + ) `thenTc` \ (prag_binds, prag_lie) -> -- Check the overloading constraints of the methods and superclasses @@ -459,13 +453,12 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys dict_bind = VarMonoBind this_dict_id dict_rhs method_binds = andMonoBindList method_binds_s - final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id)) - -- Pretty truesome main_bind = AbsBinds zonked_inst_tyvars dfun_arg_dicts_ids - [(inst_tyvars', final_dfun_id, this_dict_id)] + [(inst_tyvars', dfun_id, this_dict_id)] + emptyNameSet -- No inlines (yet) (lie_binds1 `AndMonoBinds` lie_binds2 `AndMonoBinds` method_binds `AndMonoBinds` diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 22e2a33..1857850 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,10 +4,10 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, +module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind, tcContext, tcHsTyVar, kcHsTyVar, tcExtendTyVarScope, tcExtendTopTyVarScope, - TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig, + TcSigInfo(..), tcTySig, mkTcSig, maybeSig, checkSigTyVars, sigCtxt, sigPatCtxt ) where @@ -33,9 +33,10 @@ import Type ( Type, ThetaType, mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, boxedTypeKind, unboxedTypeKind, tyVarsOfType, mkArrowKinds, getTyVar_maybe, getTyVar, - tidyOpenType, tidyOpenTypes, tidyTyVar, fullSubstTy + tidyOpenType, tidyOpenTypes, tidyTyVar ) -import Id ( mkUserId, idName, idType, idFreeTyVars ) +import Subst ( mkTopTyVarSubst, substTy ) +import Id ( mkVanillaId, idName, idType, idFreeTyVars ) import Var ( TyVar, mkTyVar ) import VarEnv import VarSet @@ -95,6 +96,13 @@ tcHsTopType ty tc_type ty `thenTc` \ ty' -> forkNF_Tc (zonkTcTypeToType ty') +tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type) +tcHsTopTypeKind ty + = -- tcAddErrCtxt (typeCtxt ty) $ + tc_type_kind ty `thenTc` \ (kind, ty') -> + forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty -> + returnNF_Tc (kind, zonked_ty) + tcHsTopBoxedType :: RenamedHsType -> TcM s Type tcHsTopBoxedType ty = -- tcAddErrCtxt (typeCtxt ty) $ @@ -159,19 +167,17 @@ tc_type_kind (MonoUsgTy usg ty) tc_type_kind (HsForAllTy (Just tv_names) context ty) = tcExtendTyVarScope tv_names $ \ tyvars -> tcContext context `thenTc` \ theta -> - case theta of - [] -> -- No context, so propagate body type - tc_type_kind ty `thenTc` \ (kind, tau) -> - returnTc (kind, mkSigmaTy tyvars [] tau) - - other -> -- Context; behave like a function type - -- This matters. Return-unboxed-tuple analysis can - -- give overloaded functions like - -- f :: forall a. Num a => (# a->a, a->a #) - -- And we want these to get through the type checker - - tc_type ty `thenTc` \ tau -> - returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau) + tc_type_kind ty `thenTc` \ (kind, tau) -> + let + body_kind | null theta = kind + | otherwise = boxedTypeKind + -- Context behaves like a function type + -- This matters. Return-unboxed-tuple analysis can + -- give overloaded functions like + -- f :: forall a. Num a => (# a->a, a->a #) + -- And we want these to get through the type checker + in + returnTc (body_kind, mkSigmaTy tyvars theta tau) \end{code} Help functions for type applications @@ -358,10 +364,6 @@ maybeSig [] name = Nothing maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name | name == sig_name = Just sig | otherwise = maybeSig sigs name - --- This little helper is useful to pass to tcPat -noSigs :: Name -> Maybe TcId -noSigs name = Nothing \end{code} @@ -371,7 +373,7 @@ tcTySig :: RenamedSig -> TcM s TcSigInfo tcTySig (Sig v ty src_loc) = tcAddSrcLoc src_loc $ tcHsType ty `thenTc` \ sigma_tc_ty -> - mkTcSig (mkUserId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> + mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo @@ -391,7 +393,8 @@ mkTcSig poly_id src_loc let tyvar_tys' = mkTyVarTys tyvars' - rho' = fullSubstTy (zipVarEnv tyvars tyvar_tys') emptyVarSet rho + rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho + -- mkTopTyVarSubst because the tyvars' are fresh (theta', tau') = splitRhoTy rho' -- This splitRhoTy tries hard to make sure that tau' is a type synonym -- wherever possible, which can improve interface files. -- 1.7.10.4