import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
- tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
+ tcExtendGlobalEnv, tcExtendKindEnv,
+ tcExtendKindEnvTvs, newFamInstTyConName,
tcExtendRecEnv, tcLookupTyVar, InstInfo )
import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition, elemIndex )
-import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan )
+import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan,
+ srcSpanStart )
import ListSetOps ( equivClasses, minusList )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
-- Add the implicit things;
-- we want them in the environment because
-- they may be mentioned in interface files
+ -- NB: All associated types and their implicit things will be added a
+ -- second time here. This doesn't matter as the definitions are
+ -- the same.
; let { implicit_things = concatMap implicitTyThings alg_tyclss }
; traceTc ((text "Adding" <+> ppr alg_tyclss)
$$ (text "and" <+> ppr implicit_things))
; tcExtendGlobalEnv implicit_things getGblEnv
}}
where
+ -- Pull associated types out of class declarations, to tie them into the
+ -- knot above.
+ -- NB: We put them in the same place in the list as `tcTyClDecl' will
+ -- eventually put the matching `TyThing's. That's crucial; otherwise,
+ -- the two argument lists of `mkGlobalThings' don't match up.
addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
addATs decl = [decl]
; t_typats <- mappM tcHsKindedType k_typats
; stupid_theta <- tcHsKindedContext k_ctxt
- ; index <- nextDFunIndex -- to generate unique names
+ ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc)
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data
tycon t_tvs))
; tc_rhs <-
case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
- NewType ->
- ASSERT( isSingleton data_cons )
- mkNewTyConRhs tc_name tycon (head data_cons)
- ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax (Just (family, t_typats, index))
+ NewType -> ASSERT( isSingleton data_cons )
+ mkNewTyConRhs tc_name tycon (head data_cons)
+ ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+ False h98_syntax (Just (family, t_typats))
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive