import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon,
- isRecursiveTyCon, tyConFamily_maybe, newTyConCo )
+ isRecursiveTyCon, isFamInstTyCon,
+ tyConFamInst_maybe, tyConFamilyCoercion_maybe,
+ newTyConCo_maybe )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyCon,
- dataConUnivTyVars, dataConInstTys,
+ dataConUnivTyVars,
dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType, dataConFullSig,
dataConStrictMarks, dataConExStricts,
Making an explicit case expression allows the simplifier to eliminate
it in the (common) case where the constructor arg is already evaluated.
+[Wrappers for data instance tycons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the case of data instances, the wrapper also applies the coercion turning
+the representation type into the family instance type to cast the result of
+the wrapper. For example, consider the declarations
+
+ data family Map k :: * -> *
+ data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+The tycon to which the datacon MapPair belongs gets a unique internal name of
+the form :R123Map, and we call it the representation tycon. In contrast, Map
+is the family tycon (accessible via tyConFamInst_maybe). The wrapper and work
+of MapPair get the types
+
+ $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+ $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+which implies that the wrapper code will have to apply the coercion moving
+between representation and family type. It is accessible via
+tyConFamilyCoercion_maybe and has kind
+
+ Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
+
+This coercion is conditionally applied by wrapFamInstBody.
\begin{code}
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)
- || isInst
+ | 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,
theta, orig_arg_tys) = dataConFullSig data_con
tycon = dataConTyCon data_con
- (isInst, instTys, familyTyCon) =
- case dataConInstTys data_con of
- Nothing -> (False, [] , familyTyCon)
- Just instTys -> (True , instTys, familyTyCon)
- where
- familyTyCon = fromJust $ tyConFamily_maybe tycon
- -- this is defined whenever `isInst'
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
subst = mkTopTvSubst eq_spec
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
- familyArgs = map (substTy subst) instTys
- result_ty = if isInst
- then mkTyConApp familyTyCon familyArgs -- instance con
- else mkTyConApp tycon result_ty_args -- ordinary con
+ result_ty = case tyConFamInst_maybe tycon of
+ -- ordinary constructor
+ Nothing -> mkTyConApp tycon result_ty_args
+ -- family instance constructor
+ Just (familyTyCon,
+ instTys) ->
+ mkTyConApp familyTyCon (map (substTy subst) 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
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
- con_app _ rep_ids = Var wrk_id `mkTyApps` result_ty_args
- `mkVarApps` ex_tvs
- `mkTyApps` map snd eq_spec
- `mkVarApps` reverse rep_ids
+ con_app _ rep_ids = wrapFamInstBody tycon result_ty_args $
+ Var wrk_id `mkTyApps` result_ty_args
+ `mkVarApps` ex_tvs
+ `mkTyApps` map snd eq_spec
+ `mkVarApps` reverse rep_ids
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
where
n = length tys
+
+-- If the type constructor is a representation type of a data instance, wrap
+-- the expression into a cast adjusting the expression type, which is an
+-- instance of the representation type, to the corresponding instance of the
+-- family instance type.
+--
+wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+wrapFamInstBody tycon args result_expr
+ | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+ | 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}
-- 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
projects / ghc-hetmet.git / blobdiff