Commit 516d3138 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Add a crucial forkM on the superclass context of IfaceClass in tcIfaceDecl

The absence of this was causing a loop when typechecking an interface
where the superclass context mentioned an associated type
   class C (T a) => D a where
     data T a

Fixes Trac #5970
parent 4ecfc7ff
......@@ -203,13 +203,13 @@ buildClass :: Bool -- True <=> do not include unfoldings
-> TcRnIf m n Class
buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
= do { traceIf (text "buildClass")
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-- The class name is the 'parent' for this datacon, not its tycon,
-- because one should import the class to get the binding for
-- the datacon
; fixM (\ rec_clas -> do { -- Only name generation inside loop
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
......@@ -278,8 +278,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
op_items tycon
}
; traceIf (text "buildClass" <+> ppr tycon)
; return result
})}
; return result }
where
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
......
......@@ -372,7 +372,6 @@ loadDecl ignore_prags mod (_version, decl)
-- the names associated with the decl
main_name <- lookupOrig mod (ifName decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name)
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
......@@ -445,6 +444,7 @@ loadDecl ignore_prags mod (_version, decl)
Nothing ->
pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
; return $ (main_name, thing) :
-- uses the invariant that implicit_names and
-- implictTyThings are bijective
......
......@@ -480,27 +480,41 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop tc_occ
; ctxt <- tcIfaceCtxt rdr_ctxt
; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
; ctxt <- mapM tc_sc rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
-- The *length* of the superclasses is used by buildClass, and hence must
-- not be inside the thunk. But the *content* maybe recursive and hence
-- must be lazy (via forkM). Example:
-- class C (T a) => D a where
-- data T a
-- Here the associated type T is knot-tied with the class, and
-- so we must not pull on T too eagerly. See Trac #5970
mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
tc_sig (IfaceClassOp occ dm rdr_ty)
= do { op_name <- lookupIfaceTop occ
; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
-- Must be done lazily for just the same reason as the
-- type of a data con; to avoid sucking in types that
-- it mentions unless it's necessray to do so
-- it mentions unless it's necessary to do so
; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl defs_decls)
......@@ -513,7 +527,7 @@ tc_iface_decl _parent ignore_prags
\tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
(mapM tcIfaceType pat_tys) (tcIfaceType ty)
mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
......@@ -619,8 +633,8 @@ look at it.
\begin{code}
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag,
ifInstCls = cls, ifInstTys = mb_tcs })
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
......@@ -629,10 +643,10 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag,
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
, ifFamInstAxiom = axiom_name } )
= do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
tcIfaceCoAxiom axiom_name
let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
return (mkImportedFamInst fam mb_tcs' axiom')
= do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
tcIfaceCoAxiom axiom_name
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedFamInst fam mb_tcs' axiom') }
\end{code}
......
......@@ -84,6 +84,9 @@ instance Eq ModulePair where
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
instance Outputable ModulePair where
ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
-- Sets of module pairs
--
type ModulePairSet = Map ModulePair ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment