ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic,
ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; mb_fam_inst <- tcFamInst mb_family
; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
- want_generic gadt_syn parent mb_fam_inst
+ gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
-tcIdDetails ty IfDFunId
- = return (DFunId (isNewTyCon (classTyCon cls)))
+tcIdDetails ty (IfDFunId ns)
+ = return (DFunId ns (isNewTyCon (classTyCon cls)))
where
- (_, cls, _) = tcSplitDFunTy ty
+ (_, _, cls, _) = tcSplitDFunTy ty
tcIdDetails _ (IfRecSelId tc naughty)
= do { tc' <- tcIfaceTyCon tc
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
- = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+ = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
+ tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
+ tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
+ tc_arg (DFunLamArg i) = return (DFunLamArg i)
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
(vcat [ ptext (sLit "In interface for") <+> ppr mod
- , hang doc 2 fail_msg ]) }
+ , hang doc 2 fail_msg
+ , ppr name <+> equals <+> ppr core_expr'
+ , ptext (sLit "Iface expr =") <+> ppr expr ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
- ; setLclEnv () $ do
- { case if_rec_types gbl_env of {
- Nothing -> return [] ;
- Just (_, get_env) -> do
- { type_env <- get_env
+ ; rec_ids <- case if_rec_types gbl_env of
+ Nothing -> return []
+ Just (_, get_env) -> do
+ { type_env <- setLclEnv () get_env
+ ; return (typeEnvIds type_env) }
; return (varEnvElts (if_tv_env lcl_env) ++
varEnvElts (if_id_env lcl_env) ++
- typeEnvIds type_env) }}}}
+ rec_ids) }
\end{code}