X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=5de2b808e3e7b7a516f0b450ea35c804b4c52127;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=4e91011ba43b90bdd005ea83bb8e28f781a34a1a;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 4e91011..5de2b80 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -1,228 +1,252 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcTyClsDecls]{Typecheck type and class declarations} \begin{code} -#include "HsVersions.h" - module TcTyClsDecls ( tcTyAndClassDecls1 ) where -import Ubiq{-uitous-} +#include "HsVersions.h" -import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), - ClassDecl(..), MonoType(..), PolyType(..), - Sig(..), MonoBinds, Fake, InPat ) -import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) ) +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), + HsType(..), HsTyVar, + ConDecl(..), ConDetails(..), BangType(..), + Sig(..), + hsDeclName + ) +import RnHsSyn ( RenamedHsDecl ) +import RnEnv ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these +import BasicTypes ( RecFlag(..), Arity ) import TcMonad -import Inst ( InstanceMapper(..) ) +import Inst ( InstanceMapper ) import TcClassDcl ( tcClassDecl1 ) -import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv, - tcExtendGlobalValEnv, tcExtendKindEnv, - tcTyVarScope, tcGetEnv ) -import TcKind ( TcKind, newKindVars ) +import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv ) +import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind ) import TcTyDecls ( tcTyDecl ) +import TcMonoType ( tcTyVarScope ) +import TyCon ( tyConKind, tyConArity, isSynTyCon ) +import Class ( Class, classBigSig ) +import Var ( tyVarKind ) import Bag -import Class ( Class(..), getClassSelIds ) -import Digraph ( findSCCs, SCC(..) ) -import Name ( Name, isTyConName ) -import PprStyle -import Pretty -import UniqSet ( UniqSet(..), emptyUniqSet, - singletonUniqSet, unionUniqSets, +import Digraph ( stronglyConnComp, SCC(..) ) +import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName ) +import Outputable +import Maybes ( mapMaybe ) +import UniqSet ( UniqSet, emptyUniqSet, + unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon, getTyConDataCons ) -import Unique ( Unique ) -import Util ( panic, pprTrace ) +import TyCon ( TyCon ) +import Unique ( Unique, Uniquable(..) ) +import Util ( panic{-, pprTrace-} ) \end{code} The main function ~~~~~~~~~~~~~~~~~ \begin{code} -data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl - -tcTyAndClassDecls1 :: InstanceMapper - -> Bag RenamedTyDecl -> Bag RenamedClassDecl +tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper -- Knot tying stuff + -> [RenamedHsDecl] -> TcM s (TcEnv s) -tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls - = sortByDependency syn_decls cls_decls decls `thenTc` \ groups -> - tcGroups inst_mapper groups - where - cls_decls = mapBag ClD rncls_decls - ty_decls = mapBag TyD rnty_decls - syn_decls = filterBag is_syn_decl ty_decls - decls = ty_decls `unionBags` cls_decls - - is_syn_decl (TyD (TySynonym _ _ _ _)) = True - is_syn_decl _ = False +tcTyAndClassDecls1 unf_env inst_mapper decls + = sortByDependency decls `thenTc` \ groups -> + tcGroups unf_env inst_mapper groups -tcGroups inst_mapper [] - = tcGetEnv `thenNF_Tc` \ env -> +tcGroups unf_env inst_mapper [] + = tcGetEnv `thenNF_Tc` \ env -> returnTc env -tcGroups inst_mapper (group:groups) - = tcGroup inst_mapper group `thenTc` \ new_env -> +tcGroups unf_env inst_mapper (group:groups) + = tcGroup unf_env inst_mapper group `thenTc` \ (group_tycons, group_classes) -> -- Extend the environment using the new tycons and classes - tcSetEnv new_env $ + tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon), + if isSynTyCon tycon then Just (tyConArity tycon) else Nothing, + tycon)) + | tycon <- group_tycons] $ + + tcExtendClassEnv [(getName clas, (classKind clas, clas)) + | clas <- group_classes] $ + -- Do the remaining groups - tcGroups inst_mapper groups + tcGroups unf_env inst_mapper groups + where + classKind clas = map (kindToTcKind . tyVarKind) tyvars + where + (tyvars, _, _, _, _) = classBigSig clas \end{code} Dealing with a group ~~~~~~~~~~~~~~~~~~~~ -\begin{code} -tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s) -tcGroup inst_mapper decls - = fixTc ( \ ~(tycons,classes,_) -> - pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ +Notice the uses of @zipLazy@, which makes sure +that the knot-tied TyVars, TyCons and Classes aren't looked at too early. + + +\begin{code} +tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class]) +tcGroup unf_env inst_mapper scc + = -- TIE THE KNOT + fixTc ( \ ~(rec_tycons, rec_classes) -> -- EXTEND TYPE AND CLASS ENVIRONMENTS - -- including their data constructors and class operations - tcExtendTyConEnv tycons $ - tcExtendClassEnv classes $ - tcExtendGlobalValEnv (concat (map getTyConDataCons tycons)) $ - tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $ + let + mk_tycon_bind (name, arity) = newKindVar `thenNF_Tc` \ kind -> + returnNF_Tc (name, (kind, arity, find name rec_tycons)) - -- SNAFFLE ENV TO RETURN - tcGetEnv `thenNF_Tc` \ final_env -> + mk_class_bind (name, arity) = newKindVars arity `thenNF_Tc` \ kinds -> + returnNF_Tc (name, (kinds, find name rec_classes)) - -- DEAL WITH TYPE VARIABLES - tcTyVarScope tyvar_names ( \ tyvars -> + find name [] = pprPanic "tcGroup" (ppr name) + find name (thing:things) | name == getName thing = thing + | otherwise = find name things - -- MANUFACTURE NEW KINDS, AND EXTEND KIND ENV - newKindVars (length tycon_names) `thenNF_Tc` \ tycon_kinds -> - newKindVars (length class_names) `thenNF_Tc` \ class_kinds -> - tcExtendKindEnv tycon_names tycon_kinds $ - tcExtendKindEnv class_names class_kinds $ + in + mapNF_Tc mk_tycon_bind tycon_names_w_arities `thenNF_Tc` \ tycon_binds -> + mapNF_Tc mk_class_bind class_names_w_arities `thenNF_Tc` \ class_binds -> + tcExtendTyConEnv tycon_binds $ + tcExtendClassEnv class_binds $ + -- DEAL WITH TYPE VARIABLES + tcTyVarScope tyvar_names ( \ tyvars -> -- DEAL WITH THE DEFINITIONS THEMSELVES - foldBag combine (tcDecl inst_mapper) - (returnTc (emptyBag, emptyBag)) - decls - ) `thenTc` \ (tycons,classes) -> - - returnTc (bagToList tycons, bagToList classes, final_env) - ) `thenTc` \ (_, _, final_env) -> - returnTc final_env + foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls + ) `thenTc` \ (tycons, classes) -> + returnTc (tycons, classes) + ) where - (tyvar_names, tycon_names, class_names) = get_binders decls + is_rec_group = case scc of + AcyclicSCC _ -> NonRecursive + CyclicSCC _ -> Recursive - combine do_a do_b - = do_a `thenTc` \ (a1,a2) -> - do_b `thenTc` \ (b1,b2) -> - returnTc (a1 `unionBags` b1, a2 `unionBags` b2) + decls = case scc of + AcyclicSCC decl -> [decl] + CyclicSCC decls -> decls + + (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls \end{code} Dealing with one decl ~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcDecl :: InstanceMapper - -> Decl - -> TcM s (Bag TyCon, Bag Class) - -tcDecl inst_mapper (TyD decl) - = tcTyDecl decl `thenTc` \ tycon -> - returnTc (unitBag tycon, emptyBag) - -tcDecl inst_mapper (ClD decl) - = tcClassDecl1 inst_mapper decl `thenTc` \ clas -> - returnTc (emptyBag, unitBag clas) +tcDecl :: RecFlag -- True => recursive group + -> GlobalValueEnv -> InstanceMapper + -> ([TyCon], [Class]) -- Accumulating parameter + -> RenamedHsDecl + -> TcM s ([TyCon], [Class]) + +tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl) + = tcTyDecl is_rec_group decl `thenTc` \ tycon -> + returnTc (tycon:tycons, classes) + +tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl) + = tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas -> + returnTc (tycons, clas:classes) \end{code} Dependency analysis ~~~~~~~~~~~~~~~~~~~ \begin{code} -sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl] -sortByDependency syn_decls cls_decls decls - = let -- CHECK FOR SYNONYM CYCLES - syn_sccs = findSCCs mk_edges syn_decls - syn_cycles = [map fmt_decl (bagToList decls) - | CyclicSCC decls <- syn_sccs] - +sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl] +sortByDependency decls + = let -- CHECK FOR CLASS CYCLES + cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges decls) + cls_cycles = [ decls | CyclicSCC decls <- cls_sccs] in - checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_` + checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_` - let -- CHECK FOR CLASS CYCLES - cls_sccs = findSCCs mk_edges cls_decls - cls_cycles = [map fmt_decl (bagToList decls) - | CyclicSCC decls <- cls_sccs] + let -- CHECK FOR SYNONYM CYCLES + syn_sccs = stronglyConnComp (filter is_syn_decl edges) + syn_cycles = [ decls | CyclicSCC decls <- syn_sccs] in - checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_` + checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_` - -- DO THE MAIN DEPENDENCY ANALYSIS + -- DO THE MAIN DEPENDENCY ANALYSIS let - decl_sccs = findSCCs mk_edges decls - scc_bags = map bag_acyclic decl_sccs + decl_sccs = stronglyConnComp edges in - returnTc (scc_bags) - + returnTc decl_sccs where - bag_acyclic (AcyclicSCC scc) = unitBag scc - bag_acyclic (CyclicSCC sccs) = sccs + edges = mapMaybe mk_edges decls + +is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True +is_syn_decl _ = False -fmt_decl (TyD (TySynonym name _ _ _)) = (ppr PprForUser name, getSrcLoc name) -fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name) +is_cls_decl (ClD _, _, _) = True +is_cls_decl other = False \end{code} Edges in Type/Class decls ~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mk_edges (TyD (TyData ctxt name _ condecls _ _ _)) - = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls)) -mk_edges (TyD (TyNew ctxt name _ condecl _ _ _)) - = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl)) -mk_edges (TyD (TySynonym name _ rhs _)) - = (getItsUnique name, set_to_bag (get_ty rhs)) -mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _)) - = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) - -get_ctxt ctxt - = unionManyUniqSets (map (set_name.fst) ctxt) - -get_cons cons - = unionManyUniqSets (map get_con cons) - where - get_con (ConDecl _ btys _) - = unionManyUniqSets (map get_bty btys) - get_con (ConOpDecl bty1 _ bty2 _) - = unionUniqSets (get_bty bty1) (get_bty bty2) - get_con (NewConDecl _ ty _) - = get_ty ty - get_con (RecConDecl _ nbtys _) - = unionManyUniqSets (map (get_bty.snd) nbtys) - - get_bty (Banged ty) = get_ty ty - get_bty (Unbanged ty) = get_ty ty - -get_ty (MonoTyVar tv) - = emptyUniqSet -get_ty (MonoTyApp name tys) - = (if isTyConName name then set_name name else emptyUniqSet) - `unionUniqSets` get_tys tys +-- mk_cls_edges looks only at the context of class decls +-- Its used when we are figuring out if there's a cycle in the +-- superclass hierarchy + +mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique]) + +mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _)) + = Just (decl, getUnique name, map (getUnique . fst) ctxt) +mk_cls_edges other_decl + = Nothing + + +mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique]) + +mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _)) + = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` + get_cons condecls `unionUniqSets` + get_deriv derivs)) + +mk_edges decl@(TyD (TySynonym name _ rhs _)) + = Just (decl, getUnique name, uniqSetToList (get_ty rhs)) + +mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _)) + = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` + get_sigs sigs)) + +mk_edges other_decl = Nothing + +get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt) + +get_deriv Nothing = emptyUniqSet +get_deriv (Just clss) = unionManyUniqSets (map set_name clss) + +get_cons cons = unionManyUniqSets (map get_con cons) + +get_con (ConDecl _ _ ctxt details _) + = get_ctxt ctxt `unionUniqSets` get_con_details details + +get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys) +get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2) +get_con_details (NewCon ty) = get_ty ty +get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys) + +get_bty (Banged ty) = get_ty ty +get_bty (Unbanged ty) = get_ty ty + +get_ty (MonoTyVar name) + = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name +get_ty (MonoTyApp ty1 ty2) + = unionUniqSets (get_ty ty1) (get_ty ty2) get_ty (MonoFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) get_ty (MonoListTy ty) - = get_ty ty -- careful when defining [] (,,) etc as -get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges! - = get_tys tys -get_ty other = panic "TcTyClsDecls:get_ty" - -get_pty (HsForAllTy _ ctxt mty) + = 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 (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty -get_pty other = panic "TcTyClsDecls:get_pty" +get_ty other = panic "TcTyClsDecls:get_ty" get_tys tys = unionManyUniqSets (map get_ty tys) @@ -230,20 +254,27 @@ get_tys tys get_sigs sigs = unionManyUniqSets (map get_sig sigs) where - get_sig (ClassOpSig _ ty _ _) = get_pty ty + get_sig (ClassOpSig _ _ ty _) = get_ty ty get_sig other = panic "TcTyClsDecls:get_sig" -set_name name = singletonUniqSet (getItsUnique name) +set_name name = unitUniqSet (getUnique name) set_to_bag set = listToBag (uniqSetToList set) \end{code} + +get_binders +~~~~~~~~~~~ Extract *binding* names from type and class decls. Type variables are -bound in type, data, newtype and class declarations and the polytypes -in the class op sigs. +bound in type, data, newtype and class declarations, + *and* the polytypes in the class op sigs. + *and* the existentially quantified contexts in datacon decls Why do we need to grab all these type variables at once, including those locally-quantified type variables in class op signatures? + + [Incidentally, this only works because the names are all unique by now.] + Because we can only commit to the final kind of a type variable when we've completed the mutually recursive group. For example: @@ -259,50 +290,54 @@ Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -get_binders :: Bag Decl - -> ([Name], -- TyVars; no dups - [Name], -- Tycons; no dups - [Name]) -- Classes; no dups +get_binders :: [RenamedHsDecl] + -> ([HsTyVar Name], -- TyVars; no dups + [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms + [(Name, Arity)]) -- Classes; no dups; with their arities get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes) where - (tyvars, tycons, classes) = foldBag union3 get_binders1 - (emptyBag,emptyBag,emptyBag) - decls + (tyvars, tycons, classes) = foldr (union3 . get_binders1) + (emptyBag,emptyBag,emptyBag) + decls union3 (a1,a2,a3) (b1,b2,b3) = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3) -get_binders1 (TyD (TyData _ name tyvars _ _ _ _)) - = (listToBag tyvars, unitBag name, emptyBag) -get_binders1 (TyD (TyNew _ name tyvars _ _ _ _)) - = (listToBag tyvars, unitBag name, emptyBag) get_binders1 (TyD (TySynonym name tyvars _ _)) - = (listToBag tyvars, unitBag name, emptyBag) -get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _)) - = (unitBag tyvar `unionBags` sigs_tvs sigs, - emptyBag, unitBag name) - --- ToDo: will this duplicate the class tyvar + = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag) +get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _)) + = (listToBag tyvars `unionBags` cons_tvs condecls, + unitBag (name,Nothing), emptyBag) +get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _)) + = (listToBag tyvars `unionBags` sigs_tvs sigs, + emptyBag, unitBag (name, length tyvars)) + +cons_tvs condecls = unionManyBags (map con_tvs condecls) + where + con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs sigs_tvs sigs = unionManyBags (map sig_tvs sigs) where - sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty - pty_tvs (HsForAllTy tvs _ _) = listToBag tvs + sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty + pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar + pty_tvs other = emptyBag \end{code} \begin{code} -typeCycleErr syn_cycles sty - = ppAboves (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles) +typeCycleErr syn_cycles + = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles) -classCycleErr cls_cycles sty - = ppAboves (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles) +classCycleErr cls_cycles + = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles) -pp_cycle sty str things - = ppHang (ppStr str) - 4 (ppAboves (map pp_thing things)) +pp_cycle str decls + = hang (text str) + 4 (vcat (map pp_decl decls)) where - pp_thing (pp_name, loc) - = ppCat [pp_name, ppr sty loc] + pp_decl decl + = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)] + where + name = hsDeclName decl \end{code}