From: simonpj@microsoft.com Date: Fri, 29 Sep 2006 14:39:10 +0000 (+0000) Subject: Global renamings in HsSyn X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1 Global renamings in HsSyn --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 41460e1..3f24a85 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -50,7 +50,7 @@ import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, 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, @@ -639,8 +639,8 @@ mkRecordSelId tycon field_label -- 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 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index d477eff..4251b20 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -513,8 +513,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ let left_id = HsVar (dataConWrapId left_con) right_id = HsVar (dataConWrapId right_con) - left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsCoerce (mkCoTyApps [ty1, ty2]) right_id) e + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 58e42fd..f47a4c7 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -419,20 +419,20 @@ addDictScc var rhs = returnDs rhs \begin{code} -dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr -dsCoercion CoHole thing_inside = thing_inside -dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside) -dsCoercion (ExprCoFn co) thing_inside = do { expr <- thing_inside +dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr +dsCoercion WpHole thing_inside = thing_inside +dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside) +dsCoercion (WpCo co) thing_inside = do { expr <- thing_inside ; return (Cast expr co) } -dsCoercion (CoLam id) thing_inside = do { expr <- thing_inside +dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside ; return (Lam id expr) } -dsCoercion (CoTyLam tv) thing_inside = do { expr <- thing_inside +dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside ; return (Lam tv expr) } -dsCoercion (CoApp id) thing_inside = do { expr <- thing_inside +dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside ; return (App expr (Var id)) } -dsCoercion (CoTyApp ty) thing_inside = do { expr <- thing_inside +dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside ; return (App expr (Type ty)) } -dsCoercion (CoLet bs) thing_inside = do { prs <- dsLHsBinds bs +dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs ; expr <- thing_inside ; return (Let (Rec prs) expr) } \end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5ffae6d..a85f100 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -121,7 +121,7 @@ ds_val_bind (NonRecursive, hsbinds) body FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn } -> matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted - ASSERT( isIdCoercion co_fn ) + ASSERT( isIdHsWrapper co_fn ) returnDs (bindNonRec fun rhs body_w_exports) PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty } @@ -205,7 +205,7 @@ dsExpr (HsVar var) = returnDs (Var var) dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsCoerce co_fn e) = dsCoercion co_fn (dsExpr e) +dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e) dsExpr (NegApp expr neg_expr) = do { core_expr <- dsLExpr expr @@ -217,7 +217,7 @@ dsExpr expr@(HsLam a_Match) returnDs (mkLams binders matching_code) #if defined(GHCI) && defined(BREAKPOINT) -dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _) +dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsWrap _ fun)) (L loc arg))) _) | HsVar funId <- fun , idName funId `elem` [breakpointJumpName, breakpointCondJumpName] , ids <- filter (isValidType . idType) (extractIds arg) @@ -233,7 +233,7 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _) extractIds (HsApp fn arg) | HsVar argId <- unLoc arg = argId:extractIds (unLoc fn) - | HsCoerce co_fn arg' <- unLoc arg + | HsWrap co_fn arg' <- unLoc arg , HsVar argId <- arg' -- SLPJ: not sure what is going on here = error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn) extractIds x = [] diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index eea61ba..a8571f1 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -94,7 +94,7 @@ matchGuards [] ctx rhs rhs_ty -- you don't get a "non-exhaustive eqns" message when the guards -- finish in "otherwise". -- NB: The success of this clause depends on the typechecker not - -- wrapping the 'otherwise' in empty HsTyApp or HsCoerce constructors + -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings matchGuards (ExprStmt (L _ (HsVar v)) _ _ : stmts) ctx rhs rhs_ty | v `hasKey` otherwiseIdKey diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 347f6b6..28ff62d 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -26,7 +26,7 @@ module DsMonad ( -- Data types DsMatchContext(..), - EquationInfo(..), MatchResult(..), DsWrapper, idWrapper, + EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, CanItFail(..), orFail ) where @@ -77,7 +77,7 @@ data EquationInfo eqn_rhs :: MatchResult } -- What to do after match type DsWrapper = CoreExpr -> CoreExpr -idWrapper e = e +idDsWrapper e = e -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult -- \fail. wrap (case vs of { pats -> rhs fail }) diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 9ff1548..b40bb53 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -392,7 +392,7 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v (ParPat pat) = tidy1 v (unLoc pat) tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 v (WildPat ty) = returnDs (idWrapper, WildPat ty) +tidy1 v (WildPat ty) = returnDs (idDsWrapper, WildPat ty) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } @@ -427,7 +427,7 @@ tidy1 v (LazyPat pat) ; returnDs (mkDsLets sel_binds, WildPat (idType v)) } tidy1 v (ListPat pats ty) - = returnDs (idWrapper, unLoc list_ConPat) + = returnDs (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -437,13 +437,13 @@ tidy1 v (ListPat pats ty) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern tidy1 v (PArrPat pats ty) - = returnDs (idWrapper, unLoc parrConPat) + = returnDs (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) tidy1 v (TuplePat pats boxity ty) - = returnDs (idWrapper, unLoc tuple_ConPat) + = returnDs (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty @@ -459,16 +459,16 @@ tidy1 v (DictPat dicts methods) -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 v (LitPat lit) - = returnDs (idWrapper, tidyLitPat lit) + = returnDs (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form tidy1 v (NPat lit mb_neg eq lit_ty) - = returnDs (idWrapper, tidyNPat lit mb_neg eq lit_ty) + = returnDs (idDsWrapper, tidyNPat lit mb_neg eq lit_ty) -- Everything else goes through unchanged... tidy1 v non_interesting_pat - = returnDs (idWrapper, non_interesting_pat) + = returnDs (idDsWrapper, non_interesting_pat) \end{code} \noindent diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 300f683..0588047 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -76,7 +76,7 @@ data HsBind id fun_matches :: MatchGroup id, -- The payload - fun_co_fn :: ExprCoFn, -- Coercion from the type of the MatchGroup to the type of + fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of -- the Id. Example: -- f :: Int -> forall a. a -> a -- f x y = y @@ -296,67 +296,67 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A ExprCoFn is an expression with a hole in it +-- A HsWrapper is an expression with a hole in it -- We need coercions to have concrete form so that we can zonk them -data ExprCoFn - = CoHole -- The identity coercion +data HsWrapper + = WpHole -- The identity coercion - | CoCompose ExprCoFn ExprCoFn -- (\a1..an. []) `CoCompose` (\x1..xn. []) + | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. []) -- = (\a1..an \x1..xn. []) - | ExprCoFn Coercion -- A cast: [] `cast` co + | WpCo Coercion -- A cast: [] `cast` co -- Guaranteedn not the identity coercion - | CoApp Var -- [] x; the xi are dicts or coercions - | CoTyApp Type -- [] t - | CoLam Id -- \x. []; the xi are dicts or coercions - | CoTyLam TyVar -- \a. [] + | WpApp Var -- [] x; the xi are dicts or coercions + | WpTyApp Type -- [] t + | WpLam Id -- \x. []; the xi are dicts or coercions + | WpTyLam TyVar -- \a. [] -- Non-empty bindings, so that the identity coercion - -- is always exactly CoHole - | CoLet (LHsBinds Id) -- let binds in [] + -- is always exactly WpHole + | WpLet (LHsBinds Id) -- let binds in [] -- (would be nicer to be core bindings) -instance Outputable ExprCoFn where - ppr co_fn = pprCoFn (ptext SLIT("<>")) co_fn +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn -pprCoFn :: SDoc -> ExprCoFn -> SDoc -pprCoFn it CoHole = it -pprCoFn it (CoCompose f1 f2) = pprCoFn (pprCoFn it f2) f1 -pprCoFn it (ExprCoFn co) = it <+> ptext SLIT("`cast`") <+> pprParendType co -pprCoFn it (CoApp id) = it <+> ppr id -pprCoFn it (CoTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty -pprCoFn it (CoLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it -pprCoFn it (CoTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it -pprCoFn it (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +pprHsWrapper it WpHole = it +pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1 +pprHsWrapper it (WpCo co) = it <+> ptext SLIT("`cast`") <+> pprParendType co +pprHsWrapper it (WpApp id) = it <+> ppr id +pprHsWrapper it (WpTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty +pprHsWrapper it (WpLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it +pprHsWrapper it (WpTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it +pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] -(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn -CoHole <.> c = c -c <.> CoHole = c -c1 <.> c2 = c1 `CoCompose` c2 +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 -mkCoTyApps :: [Type] -> ExprCoFn -mkCoTyApps tys = mk_co_fn CoTyApp (reverse tys) +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys) -mkCoApps :: [Id] -> ExprCoFn -mkCoApps ids = mk_co_fn CoApp (reverse ids) +mkWpApps :: [Id] -> HsWrapper +mkWpApps ids = mk_co_fn WpApp (reverse ids) -mkCoTyLams :: [TyVar] -> ExprCoFn -mkCoTyLams ids = mk_co_fn CoTyLam ids +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_fn WpTyLam ids -mkCoLams :: [Id] -> ExprCoFn -mkCoLams ids = mk_co_fn CoLam ids +mkWpLams :: [Id] -> HsWrapper +mkWpLams ids = mk_co_fn WpLam ids -mk_co_fn :: (a -> ExprCoFn) -> [a] -> ExprCoFn -mk_co_fn f as = foldr (CoCompose . f) CoHole as +mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_fn f as = foldr (WpCompose . f) WpHole as -idCoercion :: ExprCoFn -idCoercion = CoHole +idHsWrapper :: HsWrapper +idHsWrapper = WpHole -isIdCoercion :: ExprCoFn -> Bool -isIdCoercion CoHole = True -isIdCoercion other = False +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper other = False \end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c42be90..40866f4 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -15,7 +15,7 @@ import HsLit ( HsLit(..), HsOverLit ) import HsTypes ( LHsType, PostTcType ) import HsImpExp ( isOperator, pprHsVar ) import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds, - ExprCoFn, pprCoFn ) + HsWrapper, pprHsWrapper ) -- others: import Type ( Type, pprParendType ) @@ -240,7 +240,7 @@ The renamer translates them into the Right Thing. Everything from here on appears only in typechecker output. \begin{code} - | HsCoerce ExprCoFn -- TRANSLATION + | HsWrap HsWrapper -- TRANSLATION (HsExpr id) type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be @@ -380,7 +380,7 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] -ppr_expr (HsCoerce co_fn e) = pprCoFn (ppr_expr e) co_fn +ppr_expr (HsWrap co_fn e) = pprHsWrapper (ppr_expr e) co_fn ppr_expr (HsType id) = ppr id ppr_expr (HsSpliceE s) = pprSplice s diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index aa1568d..79b9062 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -22,7 +22,7 @@ module HsPat ( import {-# SOURCE #-} HsExpr ( SyntaxExpr ) -- friends: -import HsBinds ( DictBinds, HsBind(..), ExprCoFn, isIdCoercion, pprCoFn, +import HsBinds ( DictBinds, HsBind(..), HsWrapper, isIdHsWrapper, pprHsWrapper, emptyLHsBinds, pprLHsBinds ) import HsLit ( HsLit(HsCharPrim), HsOverLit ) import HsTypes ( LHsType, PostTcType ) @@ -126,7 +126,7 @@ data Pat id [id] -- Methods ------------ Pattern coercions (translation only) --------------- - | CoPat ExprCoFn -- If co::t1 -> t2, p::t2, + | CoPat HsWrapper -- If co::t1 -> t2, p::t2, -- then (CoPat co p) :: t1 (Pat id) -- Why not LPat? Ans: existing locn will do Type @@ -195,7 +195,7 @@ pprPat (NPat l Nothing _ _) = ppr l pprPat (NPat l (Just _) _ _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") -pprPat (CoPat co pat _) = parens (pprCoFn (ppr pat) co) +pprPat (CoPat co pat _) = parens (pprHsWrapper (ppr pat) co) pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (DictPat ds ms) = parens (sep [ptext SLIT("{-dict-}"), @@ -239,9 +239,9 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] ty mkCharLitPat :: Char -> OutPat id mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy -mkCoPat :: ExprCoFn -> OutPat id -> Type -> OutPat id +mkCoPat :: HsWrapper -> OutPat id -> Type -> OutPat id mkCoPat co lpat@(L loc pat) ty - | isIdCoercion co = lpat + | isIdHsWrapper co = lpat | otherwise = L loc (CoPat co pat ty) \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 1839aef..da0e24c 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -72,14 +72,14 @@ mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsCoerce (mkCoTyApps tys) (HsVar fun_id)) +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) -mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id -mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e) +mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id -mkHsCoerce co_fn e | isIdCoercion co_fn = e - | otherwise = HsCoerce co_fn e +mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap co_fn e | isIdHsWrapper co_fn = e + | otherwise = HsWrap co_fn e mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -224,7 +224,7 @@ nlHsFunTy a b = noLoc (HsFunTy a b) mkFunBind :: Located id -> [LMatch id] -> HsBind id -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms, - fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames } mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 14ccd27..ace6fd0 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -720,7 +720,7 @@ makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, - fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames } checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 713fe00..f1ac430 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -397,7 +397,7 @@ rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches ; checkPrecMatch inf plain_name matches' ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', - bind_fvs = trim fvs, fun_co_fn = idCoercion }), + bind_fvs = trim fvs, fun_co_fn = idHsWrapper }), [plain_name], fvs) } \end{code} @@ -445,7 +445,7 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = in checkPrecMatch inf plain_name new_group `thenM_` returnM (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group, - bind_fvs = fvs, fun_co_fn = idCoercion })), + bind_fvs = fvs, fun_co_fn = idHsWrapper })), fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds where diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 8ff7962..049123e 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -329,7 +329,7 @@ rnExpr (HsArrForm op fixity cmds) returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsCoerce + -- HsWrap \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index cff48e3..1c8cc42 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -43,7 +43,7 @@ import {-# SOURCE #-} TcExpr( tcPolyExpr ) import {-# SOURCE #-} TcUnify( unifyType ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp, - ExprCoFn(..), (<.>), mkCoTyApps, idCoercion, + HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper, nlHsLit, nlHsVar ) import TcHsSyn ( zonkId ) import TcRnMonad @@ -230,18 +230,18 @@ newDictBndr inst_loc pred ; return (Dict name pred inst_loc) } ---------------- -instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn +instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper -- Instantiate the constraints of a call -- (instCall o tys theta) -- (a) Makes fresh dictionaries as necessary for the constraints (theta) -- (b) Throws these dictionaries into the LIE --- (c) Eeturns an ExprCoFn ([.] tys dicts) +-- (c) Eeturns an HsWrapper ([.] tys dicts) instCall orig tys theta = do { loc <- getInstLoc orig ; (dicts, dict_app) <- instCallDicts loc theta ; extendLIEs dicts - ; return (dict_app <.> mkCoTyApps tys) } + ; return (dict_app <.> mkWpTyApps tys) } ---------------- instStupidTheta :: InstOrigin -> TcThetaType -> TcM () @@ -253,17 +253,17 @@ instStupidTheta orig theta ; extendLIEs dicts } ---------------- -instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn) +instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper) -- This is the key place where equality predicates -- are unleashed into the world -instCallDicts loc [] = return ([], idCoercion) +instCallDicts loc [] = return ([], idHsWrapper) instCallDicts loc (EqPred ty1 ty2 : preds) = do { unifyType ty1 ty2 -- For now, we insist that they unify right away -- Later on, when we do associated types, -- unifyType :: Type -> Type -> TcM ([Inst], Coercion) ; (dicts, co_fn) <- instCallDicts loc preds - ; return (dicts, co_fn <.> CoTyApp ty1) } + ; return (dicts, co_fn <.> WpTyApp ty1) } -- We use type application to apply the function to the -- coercion; here ty1 *is* the appropriate identity coercion @@ -272,7 +272,7 @@ instCallDicts loc (pred : preds) ; let name = mkPredName uniq (instLocSrcLoc loc) pred dict = Dict name pred loc ; (dicts, co_fn) <- instCallDicts loc preds - ; return (dict:dicts, co_fn <.> CoApp (instToId dict)) } + ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) } ------------- cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params @@ -620,8 +620,8 @@ lookupInst :: Inst -> TcM LookupInstResult lookupInst inst@(Method _ id tys theta loc) = do { (dicts, dict_app) <- instCallDicts loc theta - ; let co_fn = dict_app <.> mkCoTyApps tys - ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) } + ; let co_fn = dict_app <.> mkWpTyApps tys + ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) } where span = instLocSrcSpan loc @@ -698,11 +698,11 @@ lookupInst (Dict _ pred loc) dfun = HsVar dfun_id tys = map (substTyVar tenv') tyvars ; if null theta then - returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun)) + returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do { (dicts, dict_app) <- instCallDicts loc theta - ; let co_fn = dict_app <.> mkCoTyApps tys - ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun)) + ; let co_fn = dict_app <.> mkWpTyApps tys + ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun)) }}}} --------------- diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 2316162..b53b5ea 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -101,7 +101,7 @@ tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack tcGuardedCmd env expr stk (reft, res_ty) = do { let (co, res_ty') = refineResType reft res_ty ; body <- tcCmd env expr (stk, res_ty') - ; return (mkLHsCoerce co body) } + ; return (mkLHsWrap co body) } tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function @@ -264,7 +264,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; returnM (HsArrForm (noLoc $ HsCoerce (CoTyLam w_tv) + ; returnM (HsArrForm (noLoc $ HsWrap (WpTyLam w_tv) (unLoc $ mkHsDictLet inst_binds expr')) fixity cmds') } diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 4223af4..24f98d8 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -22,7 +22,7 @@ import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), LSig, Match(..), IPBind(..), Prag(..), HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, sigName, placeHolderNames, isPragLSig, - LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsWrap, collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind ) import TcHsSyn ( zonkId ) @@ -439,7 +439,7 @@ tcSpecPrag poly_id hs_ty inl ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) ; extendLIEs lie ; let const_dicts = map instToId lie - ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) } -- Most of the work of specialisation is done by -- the desugarer, guided by the SpecPrag diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 6e5f381..6799653 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -45,7 +45,7 @@ module TcEnv( import HsSyn ( LRuleDecl, LHsBinds, LSig, LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds, - idCoercion, (<.>) ) + idHsWrapper, (<.>) ) import TcIface ( tcImportDecl ) import IfaceEnv ( newGlobalBinder ) import TcRnMonad @@ -326,7 +326,7 @@ tcExtendIdEnv2 names_w_ids thing_inside tct_level = th_lvl, tct_type = id_ty, tct_co = if isRefineableTy id_ty - then Just idCoercion + then Just idHsWrapper else Nothing }) | (name,id) <- names_w_ids, let id_ty = idType id] le' = extendNameEnvList (tcl_env env) extra_env diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 4eb7b10..e6ab82b 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -21,8 +21,8 @@ import qualified DsMeta #endif import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsCoerce, - mkHsApp ) + HsMatchContext(..), HsRecordBinds, mkHsWrap, + mkHsApp, mkLHsWrap ) import TcHsSyn ( hsLitType ) import TcRnMonad import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType, @@ -52,7 +52,7 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst, import {- Kind parts of -} Type ( argTypeKind ) -import Id ( Id, idType, recordSelectorFieldLabel, +import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, @@ -76,7 +76,7 @@ import PrimOp ( tagToEnumKey ) import DynFlags import StaticFlags ( opt_NoMethodSharing ) import HscTypes ( TyThing(..) ) -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc ) import Util import ListSetOps ( assocMaybe ) import Maybes ( catMaybes ) @@ -114,7 +114,7 @@ tcPolyExprNC expr res_ty = do { (gen_fn, expr') <- tcGen res_ty emptyVarSet (tcPolyExprNC expr) -- Note the recursive call to tcPolyExpr, because the -- type may have multiple layers of for-alls - ; return (L (getLoc expr') (mkHsCoerce gen_fn (unLoc expr'))) } + ; return (mkLHsWrap gen_fn expr') } | otherwise = tcMonoExpr expr res_ty @@ -190,7 +190,7 @@ tcExpr (HsIPVar ip) res_ty ; co_fn <- tcSubExp ip_ty res_ty ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty ; extendLIE inst - ; return (mkHsCoerce co_fn (HsIPVar ip')) } + ; return (mkHsWrap co_fn (HsIPVar ip')) } tcExpr (HsApp e1 e2) res_ty = go e1 [e2] @@ -204,13 +204,13 @@ tcExpr (HsApp e1 e2) res_ty tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty - ; return (mkHsCoerce co_fn (HsLam match')) } + ; return (mkHsWrap co_fn (HsLam match')) } tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty ; expr' <- tcPolyExpr expr sig_tc_ty ; co_fn <- tcSubExp sig_tc_ty res_ty - ; return (mkHsCoerce co_fn (ExprWithTySigOut expr' sig_ty)) } + ; return (mkHsWrap co_fn (ExprWithTySigOut expr' sig_ty)) } tcExpr (HsType ty) res_ty = failWithTc (text "Can't handle type argument:" <+> ppr ty) @@ -256,7 +256,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' -> tcApp op 2 (tc_args arg1_ty') res_ty' - ; return (mkHsCoerce co_fn (SectionR (L loc op') arg2')) } + ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) } where doc = ptext SLIT("The section") <+> quotes (ppr in_expr) <+> ptext SLIT("takes one argument") @@ -496,7 +496,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty instStupidTheta RecordUpdOrigin theta' `thenM_` -- Phew! - returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) + returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty)) \end{code} @@ -686,7 +686,7 @@ tcIdApp fun_name n_args arg_checker res_ty -- tcFun work nicely for OpApp and Sections too ; fun' <- instFun orig fun res_subst tv_theta_prs ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn - ; return (mkHsCoerce co_fn' fun', args') } + ; return (mkHsWrap co_fn' fun', args') } \end{code} Note [Silly type synonyms in smart-app] @@ -729,7 +729,7 @@ tcId orig fun_name res_ty -- And pack up the results ; fun' <- instFun orig fun res_subst tv_theta_prs - ; return (mkHsCoerce co_fn fun') } + ; return (mkHsWrap co_fn fun') } -- Note [Push result type in] -- @@ -794,7 +794,7 @@ instFun orig fun subst tv_theta_prs go _ fun ((tys, theta) : prs) = do { co_fn <- instCall orig tys theta - ; go False (HsCoerce co_fn fun) prs } + ; go False (HsWrap co_fn fun) prs } -- Hack Alert (want_method_inst)! -- See Note [No method sharing] @@ -951,7 +951,7 @@ lookupFun orig id_name -> do { thLocalId orig id ty lvl ; case mb_co of Nothing -> return (HsVar id, ty) -- Wobbly, or no free vars - Just co -> return (mkHsCoerce co (HsVar id), ty) } + Just co -> return (mkHsWrap co (HsVar id), ty) } other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } diff --git a/compiler/typecheck/TcGadt.lhs b/compiler/typecheck/TcGadt.lhs index da115b3..87f2c8d 100644 --- a/compiler/typecheck/TcGadt.lhs +++ b/compiler/typecheck/TcGadt.lhs @@ -16,7 +16,7 @@ module TcGadt ( tcUnifyTys, BindFlag(..) ) where -import HsSyn ( ExprCoFn(..), idCoercion, isIdCoercion ) +import HsSyn ( HsWrapper(..), idHsWrapper, isIdHsWrapper ) import Coercion ( Coercion, mkSymCoercion, mkTransCoercion, mkUnsafeCoercion, mkLeftCoercion, mkRightCoercion, mkCoKind, coercionKindPredTy, splitCoercionKind, decomposeCo, coercionKind ) @@ -62,29 +62,29 @@ emptyRefinement :: Refinement emptyRefinement = (Reft emptyInScopeSet emptyVarEnv) -refineType :: Refinement -> Type -> (ExprCoFn, Type) +refineType :: Refinement -> Type -> (HsWrapper, Type) -- Apply the refinement to the type. -- If (refineType r ty) = (co, ty') -- Then co :: ty:=:ty' refineType (Reft in_scope env) ty | not (isEmptyVarEnv env), -- Common case any (`elemVarEnv` env) (varSetElems (tyVarsOfType ty)) - = (ExprCoFn (substTy co_subst ty), substTy tv_subst ty) + = (WpCo (substTy co_subst ty), substTy tv_subst ty) | otherwise - = (idCoercion, ty) -- The type doesn't mention any refined type variables + = (idHsWrapper, ty) -- The type doesn't mention any refined type variables where tv_subst = mkTvSubst in_scope (mapVarEnv snd env) co_subst = mkTvSubst in_scope (mapVarEnv fst env) -refineResType :: Refinement -> Type -> (ExprCoFn, Type) +refineResType :: Refinement -> Type -> (HsWrapper, Type) -- Like refineType, but returns the 'sym' coercion -- If (refineResType r ty) = (co, ty') -- Then co :: ty':=:ty refineResType reft ty = case refineType reft ty of - (ExprCoFn co, ty1) -> (ExprCoFn (mkSymCoercion co), ty1) - (id_co, ty1) -> ASSERT( isIdCoercion id_co ) - (idCoercion, ty1) + (WpCo co, ty1) -> (WpCo (mkSymCoercion co), ty1) + (id_co, ty1) -> ASSERT( isIdHsWrapper id_co ) + (idHsWrapper, ty1) \end{code} @@ -215,8 +215,8 @@ fixTvCoEnv in_scope env -- then use transitivity with the original coercion where (co_fn, ty') = refineType (Reft in_scope fixpt) ty - co1 | ExprCoFn co'' <- co_fn = mkTransCoercion co co'' - | otherwise = ASSERT( isIdCoercion co_fn ) co + co1 | WpCo co'' <- co_fn = mkTransCoercion co co'' + | otherwise = ASSERT( isIdHsWrapper co_fn ) co ----------------------------- fixTvSubstEnv :: InScopeSet -> TvSubstEnv -> TvSubstEnv diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 4e650c5..9fa0d6b 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -512,10 +512,10 @@ zonkExpr env (HsArrForm op fixity args) mappM (zonkCmdTop env) args `thenM` \ new_args -> returnM (HsArrForm new_op fixity new_args) -zonkExpr env (HsCoerce co_fn expr) +zonkExpr env (HsWrap co_fn expr) = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkExpr env1 expr `thenM` \ new_expr -> - return (HsCoerce new_co_fn new_expr) + return (HsWrap new_co_fn new_expr) zonkExpr env other = pprPanic "zonkExpr" (ppr other) @@ -530,23 +530,23 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn) -zonkCoFn env CoHole = return (env, CoHole) -zonkCoFn env (ExprCoFn co) = do { co' <- zonkTcTypeToType env co - ; return (env, ExprCoFn co') } -zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 +zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, CoCompose c1' c2') } -zonkCoFn env (CoLam id) = do { id' <- zonkIdBndr env id + ; return (env2, WpCompose c1' c2') } +zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co + ; return (env, WpCo co') } +zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id ; let env1 = extendZonkEnv1 env id' - ; return (env1, CoLam id') } -zonkCoFn env (CoTyLam tv) = ASSERT( isImmutableTyVar tv ) - do { return (env, CoTyLam tv) } -zonkCoFn env (CoApp id) = do { return (env, CoApp (zonkIdOcc env id)) } -zonkCoFn env (CoTyApp ty) = do { ty' <- zonkTcTypeToType env ty - ; return (env, CoTyApp ty') } -zonkCoFn env (CoLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs - ; return (env1, CoLet bs') } + ; return (env1, WpLam id') } +zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) + do { return (env, WpTyLam tv) } +zonkCoFn env (WpApp id) = do { return (env, WpApp (zonkIdOcc env id)) } +zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty + ; return (env, WpTyApp ty') } +zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, WpLet bs') } ------------------------------------------------------------------------- diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 2d59676..880a0ee 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -505,11 +505,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty cls_tycon = classTyCon cls the_coercion = make_coercion cls_tycon cls_inst_tys - coerced_rep_dict = mkHsCoerce the_coercion (HsVar rep_dict_id) + coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id) ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict - ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsCoerce wrap_fn body)) } + ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) } where ----------------------- @@ -527,12 +527,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts) -- Use tcSimplifySuperClasses to avoid creating loops, for the -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify - ; return (map instToId dicts, idCoercion, sc_binds) } + ; return (map instToId dicts, idHsWrapper, sc_binds) } make_wrapper inst_loc tvs theta Nothing -- Case (b) = do { dicts <- newDictBndrs inst_loc theta ; let dict_ids = map instToId dicts - ; return (dict_ids, mkCoTyLams tvs <.> mkCoLams dict_ids, emptyBag) } + ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) } ----------------------- -- make_coercion @@ -548,9 +548,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) , (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail , Just co_con <- newTyConCo_maybe tycon , let co = mkSymCoercion (mkTyConApp co_con tc_args) - = ExprCoFn (mkTyConApp cls_tycon (all_tys_but_last ++ [co])) + = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co])) | otherwise -- The newtype is transparent; no need for a cast - = idCoercion + = idHsWrapper ----------------------- -- make_body diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 7f5dfad..d9146d9 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -18,10 +18,10 @@ import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..), Match(..), LMatch, GRHSs(..), GRHS(..), Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..), - pprMatch, isIrrefutableHsPat, mkHsCoerce, - mkLHsCoerce, pprMatchContext, pprStmtContext, + pprMatch, isIrrefutableHsPat, mkHsWrap, + mkLHsWrap, pprMatchContext, pprStmtContext, noSyntaxExpr, matchGroupArity, pprMatches, - ExprCoFn ) + HsWrapper ) import TcRnMonad import TcGadt ( Refinement, emptyRefinement, refineResType ) @@ -61,7 +61,7 @@ same number of arguments before using @tcMatches@ to do the work. tcMatchesFun :: Name -> MatchGroup Name -> BoxyRhoType -- Expected type of function - -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body + -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body tcMatchesFun fun_name matches exp_ty = do { -- Check that they all have the same no of arguments @@ -102,7 +102,7 @@ tcMatchesCase :: TcMatchCtxt -- Case context tcMatchesCase ctxt scrut_ty matches res_ty = tcMatches ctxt [scrut_ty] res_ty matches -tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId) +tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId) tcMatchLambda match res_ty = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match @@ -260,7 +260,7 @@ tcBody body (reft, res_ty) = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft) ; let (co, res_ty') = refineResType reft res_ty ; body' <- tcPolyExpr body res_ty' - ; return (mkLHsCoerce co body') } + ; return (mkLHsWrap co body') } \end{code} @@ -477,7 +477,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid -- poly_id may have a polymorphic type -- but mono_ty is just a monomorphic type variable ; co_fn <- tcSubExp (idType poly_id) mono_ty - ; return (mkHsCoerce co_fn (HsVar poly_id)) } + ; return (mkHsWrap co_fn (HsVar poly_id)) } tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt) diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index 0afe7d2..bb9fa66 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,6 +1,6 @@ \begin{code} module TcMatches where -import HsSyn ( GRHSs, MatchGroup, ExprCoFn ) +import HsSyn ( GRHSs, MatchGroup, HsWrapper ) import Name ( Name ) import TcType ( BoxyRhoType ) import TcRnTypes( TcM, TcId ) @@ -12,5 +12,5 @@ tcGRHSsPat :: GRHSs Name tcMatchesFun :: Name -> MatchGroup Name -> BoxyRhoType - -> TcM (ExprCoFn, MatchGroup TcId) + -> TcM (HsWrapper, MatchGroup TcId) \end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f3a779b..a4f3a82 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -11,7 +11,7 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, import {-# SOURCE #-} TcExpr( tcSyntaxOp ) import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), - HsOverLit(..), HsExpr(..), ExprCoFn(..), + HsOverLit(..), HsExpr(..), HsWrapper(..), mkCoPat, LHsBinds, emptyLHsBinds, isEmptyLHsBinds, collectPatsBinders, nlHsLit ) @@ -616,7 +616,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside -- NB: We can use CoPat directly, rather than mkCoPat, as we know the -- coercion is not the identity; mkCoPat is inconvenient as it -- wants a located pattern. - = CoPat (ExprCoFn $ mkTyConApp co_con args) -- co fam ty to repr ty + = CoPat (WpCo $ mkTyConApp co_con args) -- co fam ty to repr ty (pat {pat_ty = mkTyConApp tycon args}) -- representation type pat_ty -- family inst type | otherwise diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 30c922d..b7b8bd2 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -43,7 +43,7 @@ module TcRnTypes( import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup, - ExprCoFn, IE ) + HsWrapper, IE ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, HscSource(..), @@ -424,7 +424,7 @@ data TcTyThing | ATcId { -- Ids defined in this module; may not be fully zonked tct_id :: TcId, - tct_co :: Maybe ExprCoFn, -- Nothing <=> Do not apply a GADT type refinement + tct_co :: Maybe HsWrapper, -- Nothing <=> Do not apply a GADT type refinement -- I am wobbly, or have no free -- type variables -- Just co <=> Apply any type refinement to me, diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index c592652..7379993 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -21,8 +21,8 @@ module TcSimplify ( #include "HsVersions.h" import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkCoTyApps, - ExprCoFn(..), (<.>), nlHsTyApp, emptyLHsBinds ) +import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps, + HsWrapper(..), (<.>), nlHsTyApp, emptyLHsBinds ) import TcHsSyn ( mkHsApp ) import TcRnMonad @@ -1924,8 +1924,8 @@ addSCs is_loop avails dict | is_given sc_dict = return avails | otherwise = addSCs is_loop avails' sc_dict where - sc_sel_rhs = L (instSpan dict) (HsCoerce co_fn (HsVar sc_sel)) - co_fn = CoApp (instToId dict) <.> mkCoTyApps tys + sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) + co_fn = WpApp (instToId dict) <.> mkWpTyApps tys avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) is_given :: Inst -> Bool diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 853adef..a343b23 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -25,8 +25,8 @@ module TcUnify ( #include "HsVersions.h" -import HsSyn ( ExprCoFn(..), idCoercion, isIdCoercion, (<.>), - mkCoLams, mkCoTyLams, mkCoApps ) +import HsSyn ( HsWrapper(..), idHsWrapper, isIdHsWrapper, (<.>), + mkWpLams, mkWpTyLams, mkWpApps ) import TypeRep ( Type(..), PredType(..) ) import TcMType ( lookupTcTyVar, LookupTyVarResult(..), @@ -110,7 +110,7 @@ subFunTys :: SDoc -- Somthing like "The function f has 3 arguments" -> Arity -- Expected # of args -> BoxyRhoType -- res_ty -> ([BoxySigmaType] -> BoxyRhoType -> TcM a) - -> TcM (ExprCoFn, a) + -> TcM (HsWrapper, a) -- Attempt to decompse res_ty to have enough top-level arrows to -- match the number of patterns in the match group -- @@ -154,7 +154,7 @@ subFunTys error_herald n_pats res_ty thing_inside loop 0 args_so_far res_ty = do { res <- thing_inside (reverse args_so_far) res_ty - ; return (idCoercion, res) } + ; return (idHsWrapper, res) } loop n args_so_far (FunTy arg_ty res_ty) = do { (co_fn, res) <- loop (n-1) (arg_ty:args_so_far) res_ty @@ -178,7 +178,7 @@ subFunTys error_herald n_pats res_ty thing_inside Indirect ty -> loop n args_so_far ty Flexi -> do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty - ; return (idCoercion, res) } } + ; return (idHsWrapper, res) } } where mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty' mk_res_ty [] = panic "TcUnify.mk_res_ty1" @@ -594,7 +594,7 @@ expected_ty. \begin{code} ----------------- -tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only +tcSubExp :: BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only -- (tcSub act exp) checks that -- act <= exp tcSubExp actual_ty expected_ty @@ -612,7 +612,7 @@ tcSubExp actual_ty expected_ty traceTc (text "tcSubExp" <+> ppr actual_ty <+> ppr expected_ty) >> tc_sub SubOther actual_ty actual_ty False expected_ty expected_ty -tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM ExprCoFn -- Locally used only +tcFunResTy :: Name -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper -- Locally used only tcFunResTy fun actual_ty expected_ty = traceTc (text "tcFunResTy" <+> ppr actual_ty <+> ppr expected_ty) >> tc_sub (SubFun fun) actual_ty actual_ty False expected_ty expected_ty @@ -628,7 +628,7 @@ tc_sub :: SubCtxt -- How to add an error-context -> InBox -- True <=> expected_ty is inside a box -> BoxySigmaType -- expected_ty, before -> BoxySigmaType -- ..and after - -> TcM ExprCoFn + -> TcM HsWrapper -- The acual_ty is never inside a box -- IMPORTANT pre-condition: if the args contain foralls, the bound type -- variables are visible non-monadically @@ -653,7 +653,7 @@ tc_sub1 sub_ctxt act_sty act_ty exp_ib exp_sty exp_ty tc_sub1 sub_ctxt act_sty (TyVarTy tv) exp_ib exp_sty exp_ty = do { addSubCtxt sub_ctxt act_sty exp_sty $ uVar True False tv exp_ib exp_sty exp_ty - ; return idCoercion } + ; return idHsWrapper } ----------------------------------- -- Skolemisation case (rule SKOL) @@ -739,7 +739,7 @@ tc_sub1 sub_ctxt act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_t tc_sub1 sub_ctxt act_sty actual_ty exp_ib exp_sty expected_ty = do { addSubCtxt sub_ctxt act_sty exp_sty $ u_tys True False act_sty actual_ty exp_ib exp_sty expected_ty - ; return idCoercion } + ; return idHsWrapper } ----------------------------------- @@ -751,14 +751,14 @@ tc_sub_funs act_arg act_res exp_ib exp_arg exp_res ----------------------------------- wrapFunResCoercion :: [TcType] -- Type of args - -> ExprCoFn -- HsExpr a -> HsExpr b - -> TcM ExprCoFn -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) + -> HsWrapper -- HsExpr a -> HsExpr b + -> TcM HsWrapper -- HsExpr (arg_tys -> a) -> HsExpr (arg_tys -> b) wrapFunResCoercion arg_tys co_fn_res - | isIdCoercion co_fn_res = return idCoercion + | isIdHsWrapper co_fn_res = return idHsWrapper | null arg_tys = return co_fn_res | otherwise = do { arg_ids <- newSysLocalIds FSLIT("sub") arg_tys - ; return (mkCoLams arg_ids <.> co_fn_res <.> mkCoApps arg_ids) } + ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) } \end{code} @@ -775,7 +775,7 @@ tcGen :: BoxySigmaType -- expected_ty -- quantified tyvars of expected_ty -- must not be unified -> (BoxyRhoType -> TcM result) -- spec_ty - -> TcM (ExprCoFn, result) + -> TcM (HsWrapper, result) -- The expression has type: spec_ty -> expected_ty tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type @@ -819,9 +819,9 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall ; traceTc (text "tcGen:done") ; let - -- The CoLet binds any Insts which came out of the simplification. + -- The WpLet binds any Insts which came out of the simplification. dict_ids = map instToId dicts - co_fn = mkCoTyLams forall_tvs <.> mkCoLams dict_ids <.> CoLet inst_binds + co_fn = mkWpTyLams forall_tvs <.> mkWpLams dict_ids <.> WpLet inst_binds ; returnM (co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs