X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=701c15c6f0d5dc3cb2707c34421b2354d7e08a07;hb=074d99bd864680f896b671fa354fcca6be77ae12;hp=00104dbe2e901b30d279033e4df9654d26ecdd5e;hpb=a6eede3173cee960884e732f40b0998cf84ae015;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 00104db..701c15c 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -13,7 +13,7 @@ module TcTyClsDecls ( import HsSyn ( HsDecl(..), TyClDecl(..), HsType(..), HsTyVar, ConDecl(..), ConDetails(..), BangType(..), - Sig(..), + Sig(..), HsPred(..), tyClDeclName, isClassDecl, isSynDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name ) @@ -23,26 +23,30 @@ import TcMonad import Inst ( InstanceMapper ) import TcClassDcl ( kcClassDecl, tcClassDecl1 ) import TcEnv ( ValueEnv, TcTyThing(..), - tcExtendTypeEnv + tcExtendTypeEnv, getAllEnvTyCons ) import TcTyDecls ( tcTyDecl, kcTyDecl ) import TcMonoType ( kcHsTyVar ) import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind ) import Type ( mkArrowKind, boxedTypeKind ) -import Class ( Class, classBigSig ) -import Var ( tyVarKind ) + +import Class ( Class ) +import Var ( TyVar, tyVarKind ) +import FiniteMap import Bag +import VarSet import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName ) import Outputable -import Maybes ( mapMaybe ) +import Maybes ( mapMaybe, expectJust ) import UniqSet ( UniqSet, emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import ErrUtils ( Message ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon ) +import TyCon ( TyCon, ArgVrcs ) +import Variance ( calcTyConArgVrcs ) import Unique ( Unique, Uniquable(..) ) import UniqFM ( listToUFM, lookupUFM ) \end{code} @@ -71,6 +75,9 @@ tcGroups unf_env inst_mapper (group:groups) Dealing with a group ~~~~~~~~~~~~~~~~~~~~ +The knot-tying parameters: @rec_tyclss@ is an alist mapping @Name@s to +@TcTyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. + \begin{code} tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv tcGroup unf_env inst_mapper scc @@ -80,7 +87,7 @@ tcGroup unf_env inst_mapper scc -- Tie the knot -- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_` - fixTc ( \ ~(rec_tyclss, _) -> + fixTc ( \ ~(rec_tyclss, rec_vrcs, _) -> let rec_env = listToUFM rec_tyclss in @@ -88,11 +95,17 @@ tcGroup unf_env inst_mapper scc -- Do type checking mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 -> tcExtendTypeEnv ty_env_stuff2 $ - mapTc (tcDecl is_rec_group unf_env inst_mapper) decls `thenTc` \ tyclss -> + mapTc (tcDecl is_rec_group unf_env inst_mapper rec_vrcs) decls + `thenTc` \ tyclss -> tcGetEnv `thenTc` \ env -> - returnTc (tyclss, env) - ) `thenTc` \ (_, env) -> + let + tycons = getAllEnvTyCons env + vrcs = calcTyConArgVrcs tycons + in + + returnTc (tyclss, vrcs, env) + ) `thenTc` \ (_, _, env) -> -- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_` returnTc env where @@ -116,18 +129,18 @@ kcDecl decl kcTyDecl decl tcDecl :: RecFlag -- True => recursive group - -> ValueEnv -> InstanceMapper + -> ValueEnv -> InstanceMapper -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing) -tcDecl is_rec_group unf_env inst_mapper decl +tcDecl is_rec_group unf_env inst_mapper vrcs_env decl = tcAddDeclCtxt decl $ -- traceTc (text "Starting" <+> ppr name) `thenTc_` if isClassDecl decl then - tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas -> + tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas -> -- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName clas, AClass clas) else - tcTyDecl is_rec_group decl `thenTc` \ tycon -> + tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon -> -- traceTc (text "Finished" <+> ppr name) `thenTc_` returnTc (getName tycon, ATyCon tycon) @@ -142,7 +155,7 @@ tcAddDeclCtxt decl thing_inside where (name, loc, thing) = case decl of - (ClassDecl _ name _ _ _ _ _ _ loc) -> (name, loc, "class") + (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") (TySynonym name _ _ loc) -> (name, loc, "type synonym") (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type") (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype") @@ -193,7 +206,7 @@ getTyBinding1 (TyData _ _ name tyvars _ _ _ _) Nothing, ATyCon (error "ATyCon: data"))) -getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _) +getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, Just (length tyvars), @@ -258,8 +271,8 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) -mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _) - = Just (decl, getUnique name, map (getUnique . fst) ctxt) +mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _) + = Just (decl, getUnique name, map (getUnique . get_clas) ctxt) mk_cls_edges other_decl = Nothing @@ -274,13 +287,14 @@ mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) mk_edges decl@(TySynonym name _ rhs _) = (decl, getUnique name, uniqSetToList (get_ty rhs)) -mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _) +mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) ---------------------------------------------------- -get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt) +get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt) +get_clas (HsPClass clas _) = clas ---------------------------------------------------- get_deriv Nothing = emptyUniqSet @@ -290,7 +304,7 @@ get_deriv (Just clss) = unionManyUniqSets (map set_name clss) get_cons cons = unionManyUniqSets (map get_con cons) ---------------------------------------------------- -get_con (ConDecl _ _ ctxt details _) +get_con (ConDecl _ _ _ ctxt details _) = get_ctxt ctxt `unionUniqSets` get_con_details details ---------------------------------------------------- @@ -302,6 +316,7 @@ get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbty ---------------------------------------------------- get_bty (Banged ty) = get_ty ty get_bty (Unbanged ty) = get_ty ty +get_bty (Unpacked ty) = get_ty ty ---------------------------------------------------- get_ty (MonoTyVar name) @@ -314,9 +329,14 @@ get_ty (MonoListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty get_ty (MonoTupleTy tys boxed) = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys +get_ty (MonoUsgTy _ ty) + = get_ty ty +get_ty (MonoUsgForAllTy _ ty) + = get_ty ty get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty -get_ty other = panic "TcTyClsDecls:get_ty" +get_ty (MonoDictTy name _) + = set_name name ---------------------------------------------------- get_tys tys @@ -326,7 +346,8 @@ get_tys tys get_sigs sigs = unionManyUniqSets (map get_sig sigs) where - get_sig (ClassOpSig _ _ ty _) = get_ty ty + get_sig (ClassOpSig _ _ _ ty _) = get_ty ty + get_sig (FixSig _) = emptyUniqSet get_sig other = panic "TcTyClsDecls:get_sig" ----------------------------------------------------