-%
+1%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1996-1998
%
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit,
shortCutLit, hsOverLitName,
- mkArbitraryType, -- Put this elsewhere?
-
-- re-exported from TcMonad
- TcId, TcIdSet, TcDictBinds,
+ TcId, TcIdSet,
zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
import TcMType
import TysPrim
import TysWiredIn
-import TyCon
import DataCon
import Name
import Var
import Literal
import BasicTypes
import Maybes
-import Unique
import SrcLoc
-import Util
import Bag
import Outputable
-import FastString
\end{code}
\begin{code}
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)
-thenM_ :: Monad a => a b -> a c -> a c
-thenM_ = (>>)
-
returnM :: Monad m => a -> m a
returnM = return
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box
- = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
-
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
\begin{code}
data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
- (IdEnv Id) -- What variables are in scope
- -- Maps an Id to its zonked version; both have the same Name
+ (VarEnv Var) -- What variables are in scope
+ -- Maps an Id or EvVar to its zonked version; both have the same Name
+ -- Note that all evidence (coercion variables as well as dictionaries)
+ -- are kept in the ZonkEnv
+ -- Only *type* abstraction is done by side effect
-- Is only consulted lazily; hence knot-tying
emptyZonkEnv :: ZonkEnv
emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
-extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
extendZonkEnv (ZonkEnv zonk_ty env) ids
= ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
-extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
+extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
extendZonkEnv1 (ZonkEnv zonk_ty env) id
= ZonkEnv zonk_ty (extendVarEnv env id id)
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
-zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
--- "Dictionary" binders can be coercion variables or dictionary variables
-zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
-
-zonkDictBndr :: ZonkEnv -> Var -> TcM Var
-zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var
- | otherwise = zonkIdBndr env var
-
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
--- kind contains types).
---
-zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar
-zonkTyVarBndr env tv
- | isCoVar tv
- = do { kind <- zonkTcTypeToType env (tyVarKind tv)
- ; return $ setTyVarKind tv kind
- }
- | otherwise = return tv
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+ = do { var' <- zonkEvBndr env var
+ ; return (extendZonkEnv1 env var', var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var
+ = do { ty' <- zonkTcTypeToType env (varType var)
+ ; return (setVarType var ty') }
+
+zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
+zonkEvVarOcc env v = zonkIdOcc env v
\end{code}
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
-zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
+zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
-> TcM ([Id],
+ Bag EvBind,
Bag (LHsBind Id),
[LForeignDecl Id],
[LRuleDecl Id])
-zonkTopDecls binds rules fords
- = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
+zonkTopDecls ev_binds binds rules fords
+ = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+
+ ; (env2, binds') <- zonkRecMonoBinds env1 binds
-- Top level is implicitly recursive
- ; rules' <- zonkRules env rules
- ; fords' <- zonkForeignExports env fords
- ; return (zonkEnvIds env, binds', fords', rules') }
+ ; rules' <- zonkRules env2 rules
+ ; fords' <- zonkForeignExports env2 fords
+ ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
---------------------------------------------
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
let
env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
in
- zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
+ zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
where
zonk_ip_bind (IPBind n e)
zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
zonkRecMonoBinds env binds
= fixM (\ ~(_, new_binds) -> do
- { let env1 = extendZonkEnv env (collectHsBindBinders new_binds)
+ { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 binds
; return (env1, binds') })
; new_ty <- zonkTcTypeToType env ty
; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
-zonk_bind env (VarBind { var_id = var, var_rhs = expr })
+zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
= zonkIdBndr env var `thenM` \ new_var ->
zonkLExpr env expr `thenM` \ new_expr ->
- returnM (VarBind { var_id = new_var, var_rhs = new_expr })
+ returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
-zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
+zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms
+ , fun_co_fn = co_fn })
= wrapLocM (zonkIdBndr env) var `thenM` \ new_var ->
zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
zonkMatchGroup env1 ms `thenM` \ new_ms ->
- returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
+ returnM (bind { fun_id = new_var, fun_matches = new_ms
+ , fun_co_fn = new_co_fn })
-zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts,
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds,
abs_exports = exports, abs_binds = val_binds })
= ASSERT( all isImmutableTyVar tyvars )
- zonkDictBndrs env dicts `thenM` \ new_dicts ->
- fixM (\ ~(new_val_binds, _) ->
- let
- env1 = extendZonkEnv env new_dicts
- env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds)
- in
- zonkMonoBinds env2 val_binds `thenM` \ new_val_binds ->
- mappM (zonkExport env2) exports `thenM` \ new_exports ->
- returnM (new_val_binds, new_exports)
- ) `thenM` \ (new_val_bind, new_exports) ->
- returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts,
- abs_exports = new_exports, abs_binds = new_val_bind })
+ do { (env1, new_evs) <- zonkEvBndrsX env evs
+ ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+ ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+ do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
+ ; new_val_binds <- zonkMonoBinds env3 val_binds
+ ; new_exports <- mapM (zonkExport env3) exports
+ ; return (new_val_binds, new_exports) }
+ ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
+ , abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (tyvars, global, local, prags)
-- The tyvars are already zonked
= zonkIdBndr env global `thenM` \ new_global ->
- mapM zonk_prag prags `thenM` \ new_prags ->
+ zonkSpecPrags env prags `thenM` \ new_prags ->
returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(L _ (InlinePrag {})) = return prag
- zonk_prag (L loc (SpecPrag expr ty inl))
- = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; return (L loc (SpecPrag expr' ty' inl)) }
+
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps) = do { ps' <- mapM zonk_prag ps
+ ; return (SpecPrags ps') }
+ where
+ zonk_prag (L loc (SpecPrag co_fn inl))
+ = do { (_, co_fn') <- zonkCoFn env co_fn
+ ; return (L loc (SpecPrag co_fn' inl)) }
\end{code}
%************************************************************************
zonkLExpr env expr `thenM` \ new_expr ->
returnM (SectionR new_op new_expr)
+zonkExpr env (ExplicitTuple tup_args boxed)
+ = do { new_tup_args <- mapM zonk_tup_arg tup_args
+ ; return (ExplicitTuple new_tup_args boxed) }
+ where
+ zonk_tup_arg (Present e) = do { e' <- zonkLExpr env e; return (Present e') }
+ zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
+
zonkExpr env (HsCase expr ms)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkMatchGroup env ms `thenM` \ new_ms ->
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo (zonkDo env do_or_lc)
- new_stmts new_body new_ty)
+ zonkDo env do_or_lc `thenM` \ new_do_or_lc ->
+ returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkLExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
-zonkExpr env (ExplicitTuple exprs boxed)
- = zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitTuple new_exprs boxed)
-
zonkExpr env (RecordCon data_con con_expr rbinds)
= do { new_con_expr <- zonkExpr env con_expr
; new_rbinds <- zonkRecFields env rbinds
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
-zonkCoFn env WpInline = return (env, WpInline)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
; return (env, WpCast co') }
-zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id
- ; let env1 = extendZonkEnv1 env id'
- ; return (env1, WpLam id') }
+zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
+ ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
+ ; return (env, WpEvApp arg') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
- do { tv' <- zonkTyVarBndr env tv
- ; return (env, WpTyLam tv') }
-zonkCoFn env (WpApp v)
- | isTcTyVar v = do { co <- zonkTcTyVar v
- ; return (env, WpTyApp co) }
- -- Yuk! A mutable coercion variable is a TcTyVar
- -- not a CoVar, so don't use isCoVar!
- -- Yuk! A WpApp can't hold the zonked type,
- -- so we switch to WpTyApp
- | otherwise = return (env, WpApp (zonkIdOcc env v))
+ return (env, WpTyLam tv)
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
; return (env, WpTyApp ty') }
-zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
+zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') }
-
-------------------------------------------------------------------------
-zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
+zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
-- Only used for 'do', so the only Ids are in a MDoExpr table
-zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
-zonkDo _ do_or_lc = do_or_lc
+zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
+ ; return (MDoExpr tbl') }
+zonkDo _ do_or_lc = return do_or_lc
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
-zonkStmt env (RecStmt segStmts lvs rvs rets binds)
- = zonkIdBndrs env rvs `thenM` \ new_rvs ->
- let
- env1 = extendZonkEnv env new_rvs
- in
- zonkStmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
+zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
+ , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
+ , recS_rec_rets = rets, recS_dicts = binds })
+ = do { new_rvs <- zonkIdBndrs env rvs
+ ; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_id <- zonkExpr env ret_id
+ ; new_mfix_id <- zonkExpr env mfix_id
+ ; new_bind_id <- zonkExpr env bind_id
+ ; let env1 = extendZonkEnv env new_rvs
+ ; (env2, new_segStmts) <- zonkStmts env1 segStmts
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
- mapM (zonkExpr env2) rets `thenM` \ new_rets ->
- let
- new_lvs = zonkIdOccs env2 lvs
- env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
- in
- zonkRecMonoBinds env3 binds `thenM` \ (env4, new_binds) ->
- returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets new_binds)
+ ; new_rets <- mapM (zonkExpr env2) rets
+ ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
+ ; (env4, new_binds) <- zonkTcEvBinds env3 binds
+ ; return (env4,
+ RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
+ , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
+ , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+ , recS_rec_rets = new_rets, recS_dicts = new_binds }) }
zonkStmt env (ExprStmt expr then_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
returnM (env, ExprStmt new_expr new_then new_ty)
-zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr)
+zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
= do { (env', stmts') <- zonkStmts env stmts
; let binders' = zonkIdOccs env' binders
; usingExpr' <- zonkLExpr env' usingExpr
; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
- ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') }
+ ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
-zonkStmt env (GroupStmt (stmts, binderMap) groupByClause)
+zonkStmt env (GroupStmt stmts binderMap by using)
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
- ; groupByClause' <-
- case groupByClause of
- GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing)
- GroupBySomething eitherUsingExpr byExpr -> do
- eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr
- byExpr' <- zonkLExpr env' byExpr
- return $ GroupBySomething eitherUsingExpr' byExpr'
-
+ ; by' <- fmapMaybeM (zonkLExpr env') by
+ ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
; let env'' = extendZonkEnv env' (map snd binderMap')
- ; return (env'', GroupStmt (stmts', binderMap') groupByClause') }
+ ; return (env'', GroupStmt stmts' binderMap' by' using') }
where
- mapEitherM f g x = do
- case x of
- Left a -> f a >>= (return . Left)
- Right b -> g b >>= (return . Right)
-
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
zonk_pat env (VarPatOut v binds)
= do { v' <- zonkIdBndr env v
- ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
+ ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
; returnM (env', VarPatOut v' binds') }
zonk_pat env (LazyPat pat)
zonk_pat env (ViewPat expr pat ty)
= do { expr' <- zonkLExpr env expr
; (env', pat') <- zonkPat env pat
- ; return (env', ViewPat expr' pat' ty) }
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env', ViewPat expr' pat' ty') }
zonk_pat env (ListPat pats ty)
= do { ty' <- zonkTcTypeToType env ty
; (env', pats') <- zonkPats env pats
; return (env', TuplePat pats' boxed ty') }
-zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
+zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
- ; new_dicts <- zonkDictBndrs env dicts
- ; let env1 = extendZonkEnv env new_dicts
- ; (env2, new_binds) <- zonkRecMonoBinds env1 binds
+ ; (env1, new_evs) <- zonkEvBndrsX env evs
+ ; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env', new_args) <- zonkConStuff env2 args
- ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
+ ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs,
pat_binds = new_binds, pat_args = new_args }) }
zonk_pat env (LitPat lit) = return (env, LitPat lit)
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
- = mappM zonk_bndr vars `thenM` \ new_bndrs ->
- newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
- let
- env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
- -- Type variables don't need an envt
- -- They are bound through the mutable mechanism
+ = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
- env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
+ ; unbound_tv_set <- newMutVar emptyVarSet
+ ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
-- We need to gather the type variables mentioned on the LHS so we can
-- quantify over them. Example:
-- data T a = C
-- are tiresome, because (a) the data type is big and (b) finding the
-- free type vars of an expression is necessarily monadic operation.
-- (consider /\a -> f @ b, where b is side-effected to a)
- in
- zonkLExpr env_lhs lhs `thenM` \ new_lhs ->
- zonkLExpr env_rhs rhs `thenM` \ new_rhs ->
- readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
- let
- final_bndrs :: [Located Var]
- final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
- in
- returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
- -- I hate this map RuleBndr stuff
+ ; new_lhs <- zonkLExpr env_lhs lhs
+ ; new_rhs <- zonkLExpr env_rhs rhs
+
+ ; unbound_tvs <- readMutVar unbound_tv_set
+ ; let final_bndrs :: [RuleBndr Var]
+ final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
+
+ ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
where
- zonk_bndr (RuleBndr v)
- | isId (unLoc v) = wrapLocM (zonkIdBndr env) v
- | otherwise = ASSERT( isImmutableTyVar (unLoc v) )
- return v
- zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+ zonk_bndr env (RuleBndr (L loc v))
+ = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
+ zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+
+ zonk_it env v
+ | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
+ | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
+ | otherwise = ASSERT( isImmutableTyVar v) return (env, v)
\end{code}
%************************************************************************
%* *
+ Constraints and evidence
+%* *
+%************************************************************************
+
+\begin{code}
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
+ return (EvId (zonkIdOcc env v))
+zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co
+ ; return (EvCoercion co') }
+zonkEvTerm env (EvCast v co) = ASSERT( isId v)
+ do { co' <- zonkTcTypeToType env co
+ ; return (EvCast (zonkIdOcc env v) co') }
+zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
+zonkEvTerm env (EvDFunApp df tys tms)
+ = do { tys' <- zonkTcTypeToTypes env tys
+ ; let tms' = map (zonkEvVarOcc env) tms
+ ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
+ ; return (env', EvBinds bs') }
+zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs
+ ; return (env', EvBinds bs') }
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
+ ; zonkEvBinds env (evBindMapBinds bs) }
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+ = fixM (\ ~( _, new_binds) -> do
+ { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
+ ; binds' <- mapBagM (zonkEvBind env1) binds
+ ; return (env1, binds') })
+ where
+ collect_ev_bndrs :: Bag EvBind -> [EvVar]
+ collect_ev_bndrs = foldrBag add []
+ add (EvBind var _) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env (EvBind var term)
+ = do { var' <- zonkEvBndr env var
+ ; term' <- zonkEvTerm env term
+ ; return (EvBind var' term') }
+\end{code}
+
+%************************************************************************
+%* *
\subsection[BackSubst-Foreign]{Foreign exports}
%* *
%************************************************************************
zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
-- This variant collects unbound type variables in a mutable variable
zonkTypeCollecting unbound_tv_set
- = zonkType zonk_unbound_tyvar
+ = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
where
zonk_unbound_tyvar tv
- = zonkQuantifiedTyVar tv `thenM` \ tv' ->
- readMutVar unbound_tv_set `thenM` \ tv_set ->
- writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
- return (mkTyVarTy tv')
+ = do { tv' <- zonkQuantifiedTyVar tv
+ ; tv_set <- readMutVar unbound_tv_set
+ ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
+ ; return (mkTyVarTy tv') }
zonkTypeZapping :: TcType -> TcM Type
-- This variant is used for everything except the LHS of rules
-- It zaps unbound type variables to (), or some other arbitrary type
zonkTypeZapping ty
- = zonkType zonk_unbound_tyvar ty
+ = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty
where
-- Zonk a mutable but unbound type variable to an arbitrary type
-- We know it's unbound even though we don't carry an environment,
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
+ zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
- where
- warn span msg = setSrcSpan span (addWarnTc msg)
-
-
-{- Note [Strangely-kinded void TyCons]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- See Trac #959 for more examples
-
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void. Eg.
-
- length []
-===>
- length Void (Nil Void)
-
-But in really obscure programs, the type variable might have a kind
-other than *, so we need to invent a suitably-kinded type.
-
-This commit uses
- Void for kind *
- List for kind *->*
- Tuple for kind *->...*->*
-
-which deals with most cases. (Previously, it only dealt with
-kind *.)
-
-In the other cases, it just makes up a TyCon with a suitable kind. If
-this gets into an interface file, anyone reading that file won't
-understand it. This is fixable (by making the client of the interface
-file make up a TyCon too) but it is tiresome and never happens, so I
-am leaving it.
-
-Meanwhile I have now fixed GHC to emit a civilized warning.
- -}
-
-mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
- -> TcTyVar
- -> TcRnIf g l Type -- Used by desugarer too
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
---
--- Also used by the desugarer; hence the (tiresome) parameter
--- to use when generating a warning
-mkArbitraryType warn tv
- | liftedTypeKind `isSubKind` kind -- The vastly common case
- = return anyPrimTy
- | eqKind kind (tyConKind anyPrimTyCon1) -- @*->*@
- = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
- | all isLiftedTypeKind args -- @*-> ... ->*->*@
- , isLiftedTypeKind res -- Horrible hack to make less use
- = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
- | otherwise
- = do { warn (getSrcSpan tv) msg
- ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
- -- Same name as the tyvar, apart from making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
- tup_tc = tupleTyCon Boxed (length args)
-
- msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon"))
- 2 (ptext (sLit "of kind") <+> quotes (ppr kind))
- , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv))
- , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
- , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway)."))
- , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]
-\end{code}
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff