diff options
Diffstat (limited to 'compiler/iface/BuildTyCl.lhs')
| -rw-r--r-- | compiler/iface/BuildTyCl.lhs | 43 |
1 files changed, 23 insertions, 20 deletions
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index a541e32b7b..20aea22e47 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -46,13 +46,13 @@ import Outputable \begin{code} ------------------------------------------------------ -buildSynTyCon :: Name -> [TyVar] +buildSynTyCon :: Name -> [TyVar] -> [Role] -> SynTyConRhs -> Kind -- ^ Kind of the RHS -> TyConParent -> TcRnIf m n TyCon -buildSynTyCon tc_name tvs rhs rhs_kind parent - = return (mkSynTyCon tc_name kind tvs rhs parent) +buildSynTyCon tc_name tvs roles rhs rhs_kind parent + = return (mkSynTyCon tc_name kind tvs roles rhs parent) where kind = mkPiKinds tvs rhs_kind @@ -80,7 +80,7 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs + ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) ; return (NewTyCon { data_con = con, nt_rhs = rhs_ty, @@ -90,6 +90,7 @@ mkNewTyConRhs tycon_name tycon con -- for nt_co, or uses explicit coercions otherwise where tvs = tyConTyVars tycon + roles = tyConRoles tycon inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs) rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty -- Instantiate the data con with the @@ -101,20 +102,22 @@ mkNewTyConRhs tycon_name tycon con -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns []. - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can - etad_rhs :: Type -- return a TyCon without pulling on rhs_ty - -- See Note [Tricky iface loop] in LoadIface - (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty - eta_reduce :: [TyVar] -- Reversed - -> Type -- Rhs type - -> ([TyVar], Type) -- Eta-reduced version (tyvars in normal order) - eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty, - Just tv <- getTyVar_maybe arg, - tv == a, - not (a `elemVarSet` tyVarsOfType fun) - = eta_reduce as fun - eta_reduce tvs ty = (reverse tvs, ty) + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) ------------------------------------------------------ @@ -185,14 +188,14 @@ type TcMethInfo = (Name, DefMethSpec, Type) buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors -- Used when importing a class without -O - -> Name -> [TyVar] -> ThetaType + -> Name -> [TyVar] -> [Role] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec +buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") ; dflags <- getDynFlags @@ -255,7 +258,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec ; let { clas_kind = mkPiKinds tvs constraintKind - ; tycon = mkClassTyCon tycon_name clas_kind tvs + ; tycon = mkClassTyCon tycon_name clas_kind tvs roles rhs rec_clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example |