Commit e6d05771 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Global renamings in HsSyn

parent f80b81f8
......@@ -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
......
......@@ -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.
......
......@@ -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}
......
......@@ -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 = []
......
......@@ -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
......
......@@ -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 })
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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))
}}}}
---------------
......
......@@ -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')
}
......
......@@ -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
......
......@@ -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
......
......@@ -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"))
}
......
......@@ -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
......
......@@ -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)