import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes,
- newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
+ newTyConInstRhs, mkTopTvSubst, substTyVar,
+ substTys, zipTopTvSubst )
import TcGadt ( gadtRefine, refineType, emptyRefinement )
-import HsBinds ( ExprCoFn(..), isIdCoercion )
+import HsBinds ( HsWrapper(..), isIdHsWrapper )
import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
-import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
+import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+ FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon,
isRecursiveTyCon, isFamInstTyCon,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
-import Maybe ( fromJust )
import Maybes
import PrelNames
import Util ( dropList, isSingleton )
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
subst = mkTopTvSubst eq_spec
+ famSubst = ASSERT( length (tyConTyVars tycon ) ==
+ length (mkTyVarTys univ_tvs) )
+ zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+ -- substitution mapping the type constructor's type
+ -- arguments to the universals of the data constructor
+ -- (crucial when type checking interfaces)
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
result_ty = case tyConFamInst_maybe tycon of
-- family instance constructor
Just (familyTyCon,
instTys) ->
- mkTyConApp familyTyCon (map (substTy subst) instTys)
+ mkTyConApp familyTyCon ( substTys subst
+ . substTys famSubst
+ $ instTys)
wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ result_ty
-- NB: watch out here if you allow user-written equality
-- and apply to (Maybe b'), to get (Maybe b)
rhs = case co_fn of
- ExprCoFn co -> Cast (Var the_arg_id) co
- id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id
+ WpCo co -> Cast (Var the_arg_id) co
+ id_co -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
field_vs = filter (not . isPredTy . idType) arg_vs
the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label