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,
-- 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
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.
\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}
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 }
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
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)
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 = []
-- 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
-- Data types
DsMatchContext(..),
- EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
+ EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail
) where
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 })
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[] }
; 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)
-- 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
-- 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
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
%************************************************************************
\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}
import HsTypes ( LHsType, PostTcType )
import HsImpExp ( isOperator, pprHsVar )
import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds,
- ExprCoFn, pprCoFn )
+ HsWrapper, pprHsWrapper )
-- others:
import Type ( Type, pprParendType )
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
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
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 )
[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
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-}"),
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}
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))
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
-- 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
; 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}
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
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
- -- HsCoerce
+ -- HsWrap
\end{code}
import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
- ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
+ HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper,
nlHsLit, nlHsVar )
import TcHsSyn ( zonkId )
import TcRnMonad
; 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 ()
; 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
; 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
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
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))
}}}}
---------------
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
-- 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')
}
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 )
; (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
import HsSyn ( LRuleDecl, LHsBinds, LSig,
LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds,
- idCoercion, (<.>) )
+ idHsWrapper, (<.>) )
import TcIface ( tcImportDecl )
import IfaceEnv ( newGlobalBinder )
import TcRnMonad
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
#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,
import {- Kind parts of -}
Type ( argTypeKind )
-import Id ( Id, idType, recordSelectorFieldLabel,
+import Id ( idType, recordSelectorFieldLabel,
isRecordSelector, isNaughtyRecordSelector,
isDataConId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
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 )
= 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
; 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]
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)
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")
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}
-- 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]
-- 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]
--
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]
-> 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"))
}
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 )
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}
-- 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
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)
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') }
-------------------------------------------------------------------------
; 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
-----------------------
; 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
, (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
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 )
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
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
= 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}
-- 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)
\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 )
tcMatchesFun :: Name
-> MatchGroup Name
-> BoxyRhoType
- -> TcM (ExprCoFn, MatchGroup TcId)
+ -> TcM (HsWrapper, MatchGroup TcId)
\end{code}
import {-# SOURCE #-} TcExpr( tcSyntaxOp )
import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..),
- HsOverLit(..), HsExpr(..), ExprCoFn(..),
+ HsOverLit(..), HsExpr(..), HsWrapper(..),
mkCoPat,
LHsBinds, emptyLHsBinds, isEmptyLHsBinds,
collectPatsBinders, nlHsLit )
-- 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
import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup,
- ExprCoFn, IE )
+ HsWrapper, IE )
import HscTypes ( FixityEnv,
HscEnv, TypeEnv, TyThing,
GenAvailInfo(..), AvailInfo, HscSource(..),
| 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,
#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
| 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
#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(..),
-> 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
--
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
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"
\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
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
-> 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
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)
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 }
-----------------------------------
-----------------------------------
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}
-- 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
; 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
projects / ghc-hetmet.git / commitdiff