diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/DsBinds.lhs | 59 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.lhs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 106 |
3 files changed, 105 insertions, 62 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 66022f970e..617516bd97 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -65,6 +65,7 @@ import Maybes import OrdList import Bag import BasicTypes hiding ( TopLevel ) +import Pair import DynFlags import FastString import ErrUtils( MsgDoc ) @@ -705,7 +706,7 @@ dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds return (mkCoreLets bs e) dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e -dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e) +dsHsWrapper (WpCast co) e = dsTcCoercion Representational co (mkCast e) dsHsWrapper (WpEvLam ev) e = return $ Lam ev e dsHsWrapper (WpTyLam tv) e = return $ Lam tv e dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm) @@ -739,7 +740,7 @@ dsEvTerm (EvId v) = return (Var v) dsEvTerm (EvCast tm co) = do { tm' <- dsEvTerm tm - ; dsTcCoercion co $ mkCast tm' } + ; dsTcCoercion Representational co $ mkCast tm' } -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. @@ -747,7 +748,7 @@ dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return (Var df `mkTyApps` tys `mkApps` tms') } dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] -dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox +dsEvTerm (EvCoercion co) = dsTcCoercion Nominal co mkEqBox dsEvTerm (EvTupleSel v n) = do { tm' <- dsEvTerm v @@ -785,21 +786,22 @@ dsEvTerm (EvLit l) = EvStr s -> mkStringExprFS s --------------------------------------- -dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr +dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- This is the crucial function that moves -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion -- e.g. dsTcCoercion (trans g1 g2) k -- = case g1 of EqBox g1# -> -- case g2 of EqBox g2# -> -- k (trans g1# g2#) -dsTcCoercion co thing_inside +-- thing_inside will get a coercion at the role requested +dsTcCoercion role co thing_inside = do { us <- newUniqueSupply ; let eqvs_covs :: [(EqVar,CoVar)] eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) (uniqsFromSupply us) subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] - result_expr = thing_inside (ds_tc_coercion subst co) + result_expr = thing_inside (ds_tc_coercion subst role co) result_ty = exprType result_expr ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } @@ -810,36 +812,41 @@ dsTcCoercion co thing_inside eq_nm = idName eqv occ = nameOccName eq_nm loc = nameSrcSpan eq_nm - ty = mkCoercionType ty1 ty2 + ty = mkCoercionType Nominal ty1 ty2 (ty1, ty2) = getEqPredTys (evVarPred eqv) wrap_in_case result_ty (eqv, cov) body = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] -ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion +ds_tc_coercion :: CvSubst -> Role -> TcCoercion -> Coercion -- If the incoming TcCoercion if of type (a ~ b), -- the result is of type (a ~# b) -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) -- No need for InScope set etc because the -ds_tc_coercion subst tc_co - = go tc_co +ds_tc_coercion subst role tc_co + = go role tc_co where - go (TcRefl ty) = Refl (Coercion.substTy subst ty) - go (TcTyConAppCo tc cos) = mkTyConAppCo tc (map go cos) - go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2) - go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co) + go Phantom co + = mkUnivCo Phantom ty1 ty2 + where Pair ty1 ty2 = tcCoercionKind co + + go r (TcRefl ty) = Refl r (Coercion.substTy subst ty) + go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos) + go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2) + go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co) where (subst', tv') = Coercion.substTyVarBndr subst tv - go (TcAxiomInstCo ax ind tys) - = mkAxInstCo ax ind (map (Coercion.substTy subst) tys) - go (TcSymCo co) = mkSymCo (go co) - go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) - go (TcNthCo n co) = mkNthCo n (go co) - go (TcLRCo lr co) = mkLRCo lr (go co) - go (TcInstCo co ty) = mkInstCo (go co) ty - go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co - go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) - go (TcCoVarCo v) = ds_ev_id subst v + go r (TcAxiomInstCo ax ind tys) + = mkAxInstCo r ax ind (map (Coercion.substTy subst) tys) + go r (TcSymCo co) = mkSymCo (go r co) + go r (TcTransCo co1 co2) = mkTransCo (go r co1) (go r co2) + go r (TcNthCo n co) = mkNthCoRole r n (go r co) -- the 2nd r is a harmless lie + go r (TcLRCo lr co) = maybeSubCo r $ mkLRCo lr (go Nominal co) + go r (TcInstCo co ty) = mkInstCo (go r co) ty + go r (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) r co + go r (TcCastCo co1 co2) = maybeSubCo r $ mkCoCast (go Nominal co1) + (go Nominal co2) + go r (TcCoVarCo v) = maybeSubCo r $ ds_ev_id subst v ds_co_binds :: TcEvBinds -> CvSubst ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs) @@ -851,9 +858,9 @@ ds_tc_coercion subst tc_co ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co) ds_co_term :: CvSubst -> EvTerm -> Coercion - ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co + ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst Nominal tc_co ds_co_term subst (EvId v) = ds_ev_id subst v - ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co) + ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst Nominal co) ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co) ds_ev_id :: CvSubst -> EqVar -> Coercion diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 9be8e96615..1053b91aaa 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -418,7 +418,7 @@ dsFExportDynamic id co0 cconv = do export_ty = mkFunTy stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True + (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True let {- The arguments to the external function which will diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index a60f18ded5..f92f6212a0 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -305,7 +305,7 @@ mk_extra_tvs tc tvs defn = do { uniq <- newUnique ; let { occ = mkTyVarOccFS (fsLit "t") ; nm = mkInternalName uniq occ loc - ; hs_tv = L loc (KindedTyVar nm kind) } + ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) } ; hs_tvs <- go rest ; return (hs_tv : hs_tvs) } @@ -731,10 +731,16 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) -repTyVarBndrWithKind (L _ (UserTyVar {})) nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm = repLKind ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm + = repRole r >>= repRoledTV nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm + = do { ki' <- repLKind ki + ; r' <- repRole r + ; repKindedRoledTV nm ki' r' } -- represent a type context -- @@ -878,6 +884,11 @@ repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks } repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) +repRole :: Role -> DsM (Core TH.Role) +repRole Nominal = rep2 nominalName [] +repRole Representational = rep2 representationalName [] +repRole Phantom = rep2 phantomName [] + ----------------------------------------------------------------------------- -- Splices ----------------------------------------------------------------------------- @@ -1828,6 +1839,13 @@ repPlainTV (MkC nm) = rep2 plainTVName [nm] repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] +repRoledTV :: Core TH.Name -> Core TH.Role -> DsM (Core TH.TyVarBndr) +repRoledTV (MkC nm) (MkC r) = rep2 roledTVName [nm, r] + +repKindedRoledTV :: Core TH.Name -> Core TH.Kind -> Core TH.Role + -> DsM (Core TH.TyVarBndr) +repKindedRoledTV (MkC nm) (MkC k) (MkC r) = rep2 kindedRoledTVName [nm, k, r] + repKVar :: Core TH.Name -> DsM (Core TH.Kind) repKVar (MkC s) = rep2 varKName [s] @@ -2041,7 +2059,9 @@ templateHaskellNames = [ -- TyLit numTyLitName, strTyLitName, -- TyVarBndr - plainTVName, kindedTVName, + plainTVName, kindedTVName, roledTVName, kindedRoledTVName, + -- Role + nominalName, representationalName, phantomName, -- Kind varKName, conKName, tupleKName, arrowKName, listKName, appKName, starKName, constraintKName, @@ -2319,9 +2339,17 @@ numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey -- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainTVName, kindedTVName, roledTVName, kindedRoledTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +roledTVName = libFun (fsLit "roledTV") roledTVIdKey +kindedRoledTVName = libFun (fsLit "kindedRoledTV") kindedRoledTVIdKey + +-- data Role = ... +nominalName, representationalName, phantomName :: Name +nominalName = libFun (fsLit "nominal") nominalIdKey +representationalName = libFun (fsLit "representational") representationalIdKey +phantomName = libFun (fsLit "phantom") phantomIdKey -- data Kind = ... varKName, conKName, tupleKName, arrowKName, listKName, appKName, @@ -2589,8 +2617,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 338 pragInlDIdKey = mkPreludeMiscIdUnique 339 pragSpecDIdKey = mkPreludeMiscIdUnique 340 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 412 -pragRuleDIdKey = mkPreludeMiscIdUnique 413 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 416 +pragRuleDIdKey = mkPreludeMiscIdUnique 417 familyNoKindDIdKey = mkPreludeMiscIdUnique 342 familyKindDIdKey = mkPreludeMiscIdUnique 343 dataInstDIdKey = mkPreludeMiscIdUnique 344 @@ -2658,32 +2686,40 @@ numTyLitIdKey = mkPreludeMiscIdUnique 394 strTyLitIdKey = mkPreludeMiscIdUnique 395 -- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 396 -kindedTVIdKey = mkPreludeMiscIdUnique 397 +plainTVIdKey, kindedTVIdKey, roledTVIdKey, kindedRoledTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 396 +kindedTVIdKey = mkPreludeMiscIdUnique 397 +roledTVIdKey = mkPreludeMiscIdUnique 398 +kindedRoledTVIdKey = mkPreludeMiscIdUnique 399 + +-- data Role = ... +nominalIdKey, representationalIdKey, phantomIdKey :: Unique +nominalIdKey = mkPreludeMiscIdUnique 400 +representationalIdKey = mkPreludeMiscIdUnique 401 +phantomIdKey = mkPreludeMiscIdUnique 402 -- data Kind = ... varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 398 -conKIdKey = mkPreludeMiscIdUnique 399 -tupleKIdKey = mkPreludeMiscIdUnique 400 -arrowKIdKey = mkPreludeMiscIdUnique 401 -listKIdKey = mkPreludeMiscIdUnique 402 -appKIdKey = mkPreludeMiscIdUnique 403 -starKIdKey = mkPreludeMiscIdUnique 404 -constraintKIdKey = mkPreludeMiscIdUnique 405 +varKIdKey = mkPreludeMiscIdUnique 403 +conKIdKey = mkPreludeMiscIdUnique 404 +tupleKIdKey = mkPreludeMiscIdUnique 405 +arrowKIdKey = mkPreludeMiscIdUnique 406 +listKIdKey = mkPreludeMiscIdUnique 407 +appKIdKey = mkPreludeMiscIdUnique 408 +starKIdKey = mkPreludeMiscIdUnique 409 +constraintKIdKey = mkPreludeMiscIdUnique 410 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 406 -stdCallIdKey = mkPreludeMiscIdUnique 407 +cCallIdKey = mkPreludeMiscIdUnique 411 +stdCallIdKey = mkPreludeMiscIdUnique 412 -- data Safety = ... unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 408 -safeIdKey = mkPreludeMiscIdUnique 409 -interruptibleIdKey = mkPreludeMiscIdUnique 411 +unsafeIdKey = mkPreludeMiscIdUnique 413 +safeIdKey = mkPreludeMiscIdUnique 414 +interruptibleIdKey = mkPreludeMiscIdUnique 415 -- data Inline = ... noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique @@ -2704,25 +2740,25 @@ beforePhaseDataConKey = mkPreludeDataConUnique 47 -- data FunDep = ... funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 414 +funDepIdKey = mkPreludeMiscIdUnique 418 -- data FamFlavour = ... typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 415 -dataFamIdKey = mkPreludeMiscIdUnique 416 +typeFamIdKey = mkPreludeMiscIdUnique 419 +dataFamIdKey = mkPreludeMiscIdUnique 420 -- data TySynEqn = ... tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 417 +tySynEqnIdKey = mkPreludeMiscIdUnique 421 -- quasiquoting quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 418 -quotePatKey = mkPreludeMiscIdUnique 419 -quoteDecKey = mkPreludeMiscIdUnique 420 -quoteTypeKey = mkPreludeMiscIdUnique 421 +quoteExpKey = mkPreludeMiscIdUnique 422 +quotePatKey = mkPreludeMiscIdUnique 423 +quoteDecKey = mkPreludeMiscIdUnique 424 +quoteTypeKey = mkPreludeMiscIdUnique 425 -- data RuleBndr = ... ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 422 -typedRuleVarIdKey = mkPreludeMiscIdUnique 423 +ruleVarIdKey = mkPreludeMiscIdUnique 426 +typedRuleVarIdKey = mkPreludeMiscIdUnique 427 |