X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=5de2b808e3e7b7a516f0b450ea35c804b4c52127;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=284946fa55fa55341e588fe3a5e5fedf3807a760;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 284946f..5de2b80 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -1,47 +1,47 @@ % -% (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 -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( HsDecl(..), TyDecl(..), ConDecl(..), BangType(..), - ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl, - IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr, +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), + HsType(..), HsTyVar, + ConDecl(..), ConDetails(..), BangType(..), + Sig(..), hsDeclName ) -import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl) - ) -import TcHsSyn ( SYN_IE(TcHsBinds), TcIdOcc(..) ) +import RnHsSyn ( RenamedHsDecl ) +import RnEnv ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these +import BasicTypes ( RecFlag(..), Arity ) import TcMonad -import Inst ( SYN_IE(InstanceMapper) ) +import Inst ( InstanceMapper ) import TcClassDcl ( tcClassDecl1 ) -import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv ) -import SpecEnv ( SpecEnv ) -import TcKind ( TcKind, newKindVars ) -import TcTyDecls ( tcTyDecl, mkDataBinds ) +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 ( SYN_IE(Class), classSelIds ) -import Digraph ( findSCCs, SCC(..) ) -import Name ( Name, getSrcLoc, isTvOcc, nameOccName ) -import PprStyle -import Pretty -import UniqSet ( SYN_IE(UniqSet), emptyUniqSet, +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 ) -import Unique ( Unique ) +import Unique ( Unique, Uniquable(..) ) import Util ( panic{-, pprTrace-} ) \end{code} @@ -49,181 +49,187 @@ import Util ( panic{-, pprTrace-} ) The main function ~~~~~~~~~~~~~~~~~ \begin{code} -tcTyAndClassDecls1 :: InstanceMapper +tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper -- Knot tying stuff -> [RenamedHsDecl] -> TcM s (TcEnv s) -tcTyAndClassDecls1 inst_mapper decls +tcTyAndClassDecls1 unf_env inst_mapper decls = sortByDependency decls `thenTc` \ groups -> - tcGroups inst_mapper groups + tcGroups unf_env inst_mapper groups -tcGroups inst_mapper [] +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 RenamedHsDecl -> TcM s (TcEnv s) -tcGroup inst_mapper decls - = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ - -- TIE THE KNOT - fixTc ( \ ~(tycons,classes,_) -> +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 - -- NB: it's important that the tycons and classes come back in just - -- the same order from this fix as from get_binders, so that these - -- extend-env things work properly. A bit UGH-ish. - tcExtendTyConEnv tycon_names_w_arities tycons $ - tcExtendClassEnv class_names classes $ + let + mk_tycon_bind (name, arity) = newKindVar `thenNF_Tc` \ kind -> + returnNF_Tc (name, (kind, arity, find name rec_tycons)) - -- DEAL WITH TYPE VARIABLES - tcTyVarScope tyvar_names ( \ tyvars -> + mk_class_bind (name, arity) = newKindVars arity `thenNF_Tc` \ kinds -> + returnNF_Tc (name, (kinds, find name rec_classes)) - -- DEAL WITH THE DEFINITIONS THEMSELVES - foldBag combine (tcDecl inst_mapper) - (returnTc (emptyBag, emptyBag)) - decls - ) `thenTc` \ (tycon_bag,class_bag) -> - let - tycons = bagToList tycon_bag - classes = bagToList class_bag - in + find name [] = pprPanic "tcGroup" (ppr name) + find name (thing:things) | name == getName thing = thing + | otherwise = find name things - -- SNAFFLE ENV TO RETURN - tcGetEnv `thenNF_Tc` \ final_env -> + 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 $ - returnTc (tycons, classes, final_env) - ) `thenTc` \ (_, _, final_env) -> + -- DEAL WITH TYPE VARIABLES + tcTyVarScope tyvar_names ( \ tyvars -> - returnTc final_env + -- DEAL WITH THE DEFINITIONS THEMSELVES + foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls + ) `thenTc` \ (tycons, classes) -> + returnTc (tycons, classes) + ) where - (tyvar_names, tycon_names_w_arities, 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 +tcDecl :: RecFlag -- True => recursive group + -> GlobalValueEnv -> InstanceMapper + -> ([TyCon], [Class]) -- Accumulating parameter -> RenamedHsDecl - -> TcM s (Bag TyCon, Bag Class) + -> TcM s ([TyCon], [Class]) -tcDecl inst_mapper (TyD decl) - = tcTyDecl decl `thenTc` \ tycon -> - returnTc (unitBag tycon, emptyBag) +tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl) + = tcTyDecl is_rec_group decl `thenTc` \ tycon -> + returnTc (tycon:tycons, classes) -tcDecl inst_mapper (ClD decl) - = tcClassDecl1 inst_mapper decl `thenTc` \ clas -> - returnTc (emptyBag, unitBag clas) +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 :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl] +sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl] sortByDependency decls - = let -- CHECK FOR SYNONYM CYCLES - syn_sccs = findSCCs mk_edges syn_decls - syn_cycles = [ map fmt_decl (bagToList decls) - | CyclicSCC decls <- syn_sccs] - + = 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 ty_cls_decls - scc_bags = map bag_acyclic decl_sccs + decl_sccs = stronglyConnComp edges in - returnTc (scc_bags) - + returnTc decl_sccs where - syn_decls = listToBag (filter is_syn_decl decls) - ty_cls_decls = listToBag (filter is_ty_cls_decl decls) - cls_decls = listToBag (filter is_cls_decl decls) - + edges = mapMaybe mk_edges decls +is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True +is_syn_decl _ = False -bag_acyclic (AcyclicSCC scc) = unitBag scc -bag_acyclic (CyclicSCC sccs) = sccs - -is_syn_decl (TyD (TySynonym _ _ _ _)) = True -is_syn_decl _ = False - -is_ty_cls_decl (TyD _) = True -is_ty_cls_decl (ClD _) = True -is_ty_cls_decl other = False - -is_cls_decl (ClD _) = True -is_cls_decl other = False - -fmt_decl decl - = (ppr PprForUser name, getSrcLoc name) - where - name = hsDeclName decl +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 derivs _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` - get_cons condecls `unionUniqSets` - get_deriv derivs)) +-- 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 (TyD (TyNew ctxt name _ condecl derivs _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` - get_con condecl `unionUniqSets` - get_deriv derivs)) +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 (TyD (TySynonym name _ rhs _)) - = (uniqueOf name, set_to_bag (get_ty rhs)) +mk_edges decl@(TyD (TySynonym name _ rhs _)) + = Just (decl, getUnique name, uniqSetToList (get_ty rhs)) -mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) +mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _)) + = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` + get_sigs sigs)) -get_ctxt ctxt - = unionManyUniqSets (map (set_name.fst) ctxt) +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_cons cons = unionManyUniqSets (map get_con cons) + +get_con (ConDecl _ _ ctxt details _) + = get_ctxt ctxt `unionUniqSets` get_con_details details -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_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 @@ -234,10 +240,10 @@ 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 tc ty) - = set_name tc `unionUniqSets` get_ty ty -get_ty (MonoTupleTy tc tys) - = set_name tc `unionUniqSets` get_tys tys +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 (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty get_ty other = panic "TcTyClsDecls:get_ty" @@ -251,7 +257,7 @@ get_sigs sigs get_sig (ClassOpSig _ _ ty _) = get_ty ty get_sig other = panic "TcTyClsDecls:get_sig" -set_name name = unitUniqSet (uniqueOf name) +set_name name = unitUniqSet (getUnique name) set_to_bag set = listToBag (uniqSetToList set) \end{code} @@ -260,11 +266,15 @@ set_to_bag set = listToBag (uniqSetToList set) 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: @@ -280,29 +290,32 @@ Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -get_binders :: Bag RenamedHsDecl +get_binders :: [RenamedHsDecl] -> ([HsTyVar Name], -- TyVars; no dups [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms - [Name]) -- Classes; no dups + [(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,Nothing), emptyBag) -get_binders1 (TyD (TyNew _ name tyvars _ _ _ _)) - = (listToBag tyvars, unitBag (name,Nothing), emptyBag) get_binders1 (TyD (TySynonym name tyvars _ _)) = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag) -get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _)) - = (unitBag tyvar `unionBags` sigs_tvs sigs, - emptyBag, unitBag name) +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 @@ -313,16 +326,18 @@ sigs_tvs sigs = unionManyBags (map sig_tvs sigs) \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}