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,
- newTyConCo )
+ newTyConCo_maybe )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
-import Maybe ( fromJust )
import Maybes
import PrelNames
import Util ( dropList, isSingleton )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
- = DCIds Nothing nt_work_id -- Newtype, only has a worker
+ = DCIds Nothing nt_work_id -- Newtype, only has a worker
- | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
- || not (null eq_spec)
- || isFamInstTyCon tycon
+ | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
+ || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs
+ || isFamInstTyCon tycon -- depends on this test
= DCIds (Just alg_wrap_id) wrk_id
- | otherwise -- Algebraic, no wrapper
+ | otherwise -- Algebraic, no wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
-- 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
| otherwise
= result_expr
+-- Apply the coercion in the opposite direction.
+--
+unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+unwrapFamInstBody tycon args result_expr
+ | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = mkCoerce (mkTyConApp co_con args) result_expr
+ | otherwise
+ = result_expr
+
\end{code}
-- 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
-- If a coercion constructor is prodivided in the newtype, then we use
-- it, otherwise the wrap/unwrap are both no-ops
--
+-- If the we are dealing with a newtype instance, we have a second coercion
+-- identifying the family instance with the constructor of the newtype
+-- instance. This coercion is applied in any case (ie, composed with the
+-- coercion constructor of the newtype or applied by itself).
+--
wrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo tycon
- = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
- | otherwise
- = result_expr
+ = wrapFamInstBody tycon args inner
+ where
+ inner
+ | Just co_con <- newTyConCo_maybe tycon
+ = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+ | otherwise
+ = result_expr
+-- When unwrapping, we do *not* apply any family coercion, because this will
+-- be done via a CoPat by the type checker. We have to do it this way as
+-- computing the right type arguments for the coercion requires more than just
+-- a spliting operation (cf, TcPat.tcConPat).
+--
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo tycon
+ | Just co_con <- newTyConCo_maybe tycon
= mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr