Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
84b4b408
Commit
84b4b408
authored
Jan 17, 2008
by
twanvl
Browse files
Monadify typecheck/TcBinds: use do, return and standard monad functions
parent
c1b6c0c6
Changes
1
Hide whitespace changes
Inline
Side-by-side
compiler/typecheck/TcBinds.lhs
View file @
84b4b408
...
...
@@ -56,6 +56,8 @@ import List
import Util
import BasicTypes
import Outputable
import Control.Monad
\end{code}
...
...
@@ -141,11 +143,11 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
-- I wonder if we should do these one at at time
-- Consider ?x = 4
-- ?y = ?x + 1
tc_ip_bind (IPBind ip expr)
=
newFlexiTyVarTy argTypeKind
`thenM` \ ty ->
newIPDict (IPBindOrigin ip) ip ty
`thenM` \ (ip', ip_inst) ->
tcMonoExpr expr ty
`thenM` \ expr' ->
return
M
(ip_inst, (IPBind ip' expr'))
tc_ip_bind (IPBind ip expr)
= do
ty <-
newFlexiTyVarTy argTypeKind
(ip', ip_inst) <-
newIPDict (IPBindOrigin ip) ip ty
expr' <-
tcMonoExpr expr ty
return (ip_inst, (IPBind ip' expr'))
------------------------
tcValBinds :: TopLevelFlag
...
...
@@ -575,9 +577,9 @@ tcMonoBinds binds sig_fn non_rec
-- A monomorphic binding for each term variable that lacks
-- a type sig. (Ones with a sig are already in scope.)
; binds' <- tcExtendIdEnv2 rhs_id_env $
; binds' <- tcExtendIdEnv2 rhs_id_env $
do
traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env])
`thenM_`
| (n,id) <- rhs_id_env])
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_info) }
...
...
@@ -743,7 +745,7 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-- Check that signature type variables are OK
; final_qtvs <- checkSigsTyVars qtvs sigs
; return
M
(final_qtvs, sig_lie, binds) }
; return (final_qtvs, sig_lie, binds) }
where
bndrs = bndrNames mono_infos
sigs = [sig | (_, Just sig, _) <- mono_infos]
...
...
@@ -799,7 +801,7 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
= do { gbl_tvs <- tcGetGlobalTyVars
; sig_tvs_s <- map
p
M (check_sig gbl_tvs) sigs
; sig_tvs_s <- mapM (check_sig gbl_tvs) sigs
; let -- Sigh. Make sure that all the tyvars in the type sigs
-- appear in the returned ty var list, which is what we are
...
...
@@ -811,15 +813,15 @@ checkSigsTyVars qtvs sigs
-- Here, 'a' won't appear in qtvs, so we have to add it
sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
; return
M
all_tvs }
; return all_tvs }
where
check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
sig_theta = theta, sig_tau = tau})
= addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $
addErrCtxtM (sigCtxt id tvs theta tau) $
do { tvs' <- checkDistinctTyVars tvs
;
ifM
(any (`elemVarSet` gbl_tvs) tvs')
(bleatEscapedTvs gbl_tvs tvs tvs')
;
when
(any (`elemVarSet` gbl_tvs) tvs')
(bleatEscapedTvs gbl_tvs tvs tvs')
; return tvs' }
checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment