zonkTopDecls :: Bag EvBind
-> LHsBinds TcId -> NameSet
- -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
- -> TcM ([Id],
- Bag EvBind,
- Bag (LHsBind Id),
- [LForeignDecl Id],
- [LTcSpecPrag],
- [LRuleDecl Id])
-zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
- = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+ -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
+ -> TcM ([Id],
+ Bag EvBind,
+ Bag (LHsBind Id),
+ [LForeignDecl Id],
+ [LTcSpecPrag],
+ [LRuleDecl Id],
+ [LVectDecl Id])
+zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
+ = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-- Warn about missing signatures
-- Do this only when we we have a type to offer
| otherwise = noSigWarn
; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
- -- Top level is implicitly recursive
- ; rules' <- zonkRules env2 rules
+ -- Top level is implicitly recursive
+ ; rules' <- zonkRules env2 rules
+ ; vects' <- zonkVects env2 vects
; specs' <- zonkLTcSpecPrags env2 imp_specs
- ; fords' <- zonkForeignExports env2 fords
- ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
+ ; fords' <- zonkForeignExports env2 fords
+ ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
---------------------------------------------
zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
= zonkLExpr env e `thenM` \new_e ->
returnM (HsPar new_e)
+zonkExpr env (HsHetMetBrak c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetBrak c' e')
+
+zonkExpr env (HsHetMetEsc c t e)
+ = do c' <- zonkTcTypeToType env c
+ t' <- zonkTcTypeToType env t
+ e' <- zonkLExpr env e
+ return (HsHetMetEsc c' t' e')
+
+zonkExpr env (HsHetMetCSP c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetCSP c' e')
+
zonkExpr env (SectionL expr op)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkLExpr env op `thenM` \ new_op ->
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkDo env do_or_lc `thenM` \ new_do_or_lc ->
- returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
+ returnM (HsDo do_or_lc new_stmts new_body new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
; return (env1, WpLet bs') }
-------------------------------------------------------------------------
-zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
--- Only used for 'do', so the only Ids are in a MDoExpr table
-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)
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
= do { ty' <- zonkTcTypeToType env ty
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 })
+ , recS_rec_rets = rets })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_id <- zonkExpr env ret_id
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
; 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,
+ ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed
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 }) }
+ , recS_rec_rets = new_rets }) }
zonkStmt env (ExprStmt expr then_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
| otherwise = ASSERT( isImmutableTyVar v) return (env, v)
\end{code}
+\begin{code}
+zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
+zonkVects env = mappM (wrapLocM (zonkVect env))
+
+zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
+zonkVect env (HsVect v Nothing)
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; return $ HsVect v' Nothing
+ }
+zonkVect env (HsVect v (Just e))
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; e' <- zonkLExpr env e
+ ; return $ HsVect v' (Just e')
+ }
+\end{code}
%************************************************************************
%* *
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 _deps) -- Ignore the dependencies
+zonkEvTerm env (EvDFunApp df tys tms)
= do { tys' <- zonkTcTypeToTypes env tys
; let tms' = map (zonkEvVarOcc env) tms
- ; return (EvDFunApp (zonkIdOcc env df) tys' tms' _deps) }
+ ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
= zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
where
zonk_unbound_tyvar tv
- = do { tv' <- zonkQuantifiedTyVar tv
+ = do { tv' <- zonkQuantifiedTyVar tv
; tv_set <- readMutVar unbound_tv_set
; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
; return (mkTyVarTy tv') }
projects / ghc-hetmet.git / blobdiff