import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
ClassDecl(..), MonoType(..), PolyType(..),
- Sig(..), MonoBinds, Fake, InPat )
-import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
+ Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
+import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
+ RnName(..){-instance Uniquable-}
+ )
+import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcExtendGlobalValEnv, tcExtendKindEnv,
+ tcExtendGlobalValEnv,
tcTyVarScope, tcGetEnv )
import TcKind ( TcKind, newKindVars )
-import TcTyDecls ( tcTyDecl )
+import TcTyDecls ( tcTyDecl, mkDataBinds )
import Bag
-import Class ( Class(..), getClassSelIds )
+import Class ( Class(..), classSelIds )
import Digraph ( findSCCs, SCC(..) )
-import Name ( Name, isTyConName )
+import Name ( getSrcLoc )
import PprStyle
import Pretty
import UniqSet ( UniqSet(..), emptyUniqSet,
- singletonUniqSet, unionUniqSets,
+ unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, getTyConDataCons )
+import TyCon ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon )
import Unique ( Unique )
import Util ( panic, pprTrace )
is_syn_decl _ = False
tcGroups inst_mapper []
- = tcGetEnv `thenNF_Tc` \ env ->
+ = tcGetEnv `thenNF_Tc` \ env ->
returnTc env
tcGroups inst_mapper (group:groups)
\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))) $
- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
+ -- TIE THE KNOT
+ fixTc ( \ ~(tycons,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)) $
-
- -- SNAFFLE ENV TO RETURN
- tcGetEnv `thenNF_Tc` \ final_env ->
+ -- 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 $
-- DEAL WITH TYPE VARIABLES
tcTyVarScope tyvar_names ( \ tyvars ->
- -- 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 $
-
-
-- DEAL WITH THE DEFINITIONS THEMSELVES
foldBag combine (tcDecl inst_mapper)
(returnTc (emptyBag, emptyBag))
decls
- ) `thenTc` \ (tycons,classes) ->
+ ) `thenTc` \ (tycon_bag,class_bag) ->
+ let
+ tycons = bagToList tycon_bag
+ classes = bagToList class_bag
+ in
+
+ -- SNAFFLE ENV TO RETURN
+ tcGetEnv `thenNF_Tc` \ final_env ->
- returnTc (bagToList tycons, bagToList classes, final_env)
+ returnTc (tycons, classes, final_env)
) `thenTc` \ (_, _, final_env) ->
+
returnTc final_env
where
- (tyvar_names, tycon_names, class_names) = get_binders decls
+ (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
+
+ tyvar_names = map de_rn tyvar_rn_names
+ de_rn (RnName n) = n
combine do_a do_b
= do_a `thenTc` \ (a1,a2) ->
bag_acyclic (AcyclicSCC scc) = unitBag scc
bag_acyclic (CyclicSCC sccs) = sccs
-fmt_decl (TyD (TySynonym name _ _ _)) = (ppr PprForUser name, getSrcLoc name)
-fmt_decl (ClD (ClassDecl _ name _ _ _ _ _)) = (ppr PprForUser name, getSrcLoc name)
+fmt_decl decl
+ = (ppr PprForUser name, getSrcLoc name)
+ where
+ name = get_name decl
+ get_name (TyD (TyData _ name _ _ _ _ _)) = name
+ get_name (TyD (TyNew _ name _ _ _ _ _)) = name
+ get_name (TyD (TySynonym name _ _ _)) = name
+ get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
\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 (TyData ctxt name _ condecls derivs _ _))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs))
+mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs))
mk_edges (TyD (TySynonym name _ rhs _))
- = (getItsUnique name, set_to_bag (get_ty rhs))
+ = (uniqueOf 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))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
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)
where
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_bty (Banged ty) = get_pty ty
+ get_bty (Unbanged ty) = get_pty ty
get_ty (MonoTyVar tv)
= emptyUniqSet
get_ty (MonoTyApp name tys)
- = (if isTyConName name then set_name name else emptyUniqSet)
+ = (if isRnTyCon name then set_name name else emptyUniqSet)
`unionUniqSets` get_tys tys
get_ty (MonoFunTy ty1 ty2)
= unionUniqSets (get_ty ty1) (get_ty ty2)
get_sig (ClassOpSig _ ty _ _) = get_pty ty
get_sig other = panic "TcTyClsDecls:get_sig"
-set_name name = singletonUniqSet (getItsUnique name)
+set_name name = unitUniqSet (uniqueOf 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.
\begin{code}
get_binders :: Bag Decl
- -> ([Name], -- TyVars; no dups
- [Name], -- Tycons; no dups
- [Name]) -- Classes; no dups
+ -> ([RnName], -- TyVars; no dups
+ [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
+ [RnName]) -- Classes; no dups
get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
where
= (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
get_binders1 (TyD (TyData _ name tyvars _ _ _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
get_binders1 (TyD (TyNew _ name tyvars _ _ _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
get_binders1 (TyD (TySynonym name tyvars _ _))
- = (listToBag tyvars, unitBag name, emptyBag)
+ = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
= (unitBag tyvar `unionBags` sigs_tvs sigs,
emptyBag, unitBag name)
--- ToDo: will this duplicate the class tyvar
-
sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
where
sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
- pty_tvs (HsForAllTy tvs _ _) = listToBag tvs
+ pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
\end{code}
projects / ghc-hetmet.git / blobdiff