X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=3b9a49646ea6a5528bd1a48a1949c95d8984e61b;hb=b98f161bba5030db590c50728fa60be342e5edc7;hp=9e60bbd47f29bb61f0bf384a7130be8183ed75be;hpb=43a2e4a26175b9dbf29e39b97f7d032ef00f9993;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9e60bbd..3b9a496 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -18,8 +18,6 @@ module TcBinds ( tcLocalBinds, tcTopBinds, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where -#include "HsVersions.h" - import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) @@ -56,6 +54,9 @@ import List import Util import BasicTypes import Outputable +import FastString + +import Control.Monad \end{code} @@ -115,7 +116,7 @@ tcHsBootSigs (ValBindsOut binds sigs) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message -badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") +badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing @@ -141,11 +142,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' -> - returnM (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 @@ -313,8 +314,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do - { traceTc (ptext SLIT("------------------------------------------------")) - ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + { traceTc (ptext (sLit "------------------------------------------------")) + ; traceTc (ptext (sLit "Bindings for") <+> ppr binder_names) -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) @@ -412,7 +413,7 @@ tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags tc_prag prag = addErrCtxt (pragSigCtxt prag) $ tcPrag poly_id prag -pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) +pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -- Pre-condition: the poly_id is zonked @@ -476,18 +477,18 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos check_sig other = return () strictBindErr flavour unlifted mbind - = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) + = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 4 (pprLHsBinds mbind) where - msg | unlifted = ptext SLIT("bindings for unlifted types") - | otherwise = ptext SLIT("bang-pattern bindings") + msg | unlifted = ptext (sLit "bindings for unlifted types") + | otherwise = ptext (sLit "bang-pattern bindings") badStrictSig unlifted sig - = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) + = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg) 4 (ppr sig) where - msg | unlifted = ptext SLIT("an unlifted binding") - | otherwise = ptext SLIT("a bang-pattern binding") + msg | unlifted = ptext (sLit "an unlifted binding") + | otherwise = ptext (sLit "a bang-pattern binding") \end{code} @@ -575,9 +576,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 +744,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 - ; returnM (final_qtvs, sig_lie, binds) } + ; return (final_qtvs, sig_lie, binds) } where bndrs = bndrNames mono_infos sigs = [sig | (_, Just sig, _) <- mono_infos] @@ -751,7 +752,7 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req | otherwise = exactTyVarsOfType tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos is_mono_sig sig = null (sig_theta sig) - doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs + doc = ptext (sLit "type signature(s) for") <+> pprBinders bndrs mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_loc = loc }) mono_id @@ -793,13 +794,13 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts checkTc (all isIdentityCoercion cois) - (ptext SLIT("Mutually dependent functions have syntactically distinct contexts")) + (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs = do { gbl_tvs <- tcGetGlobalTyVars - ; sig_tvs_s <- mappM (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 +812,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) - ; returnM 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)) $ + = 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] @@ -850,8 +851,8 @@ checkDistinctTyVars sig_tvs = do { env0 <- tcInitTidyEnv ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1 (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 - msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) - <+> ptext SLIT("is unified with another quantified type variable") + msg = ptext (sLit "Quantified type variable") <+> quotes (ppr tidy_tv1) + <+> ptext (sLit "is unified with another quantified type variable") <+> quotes (ppr tidy_tv2) ; failWithTcM (env2, msg) } where @@ -1071,7 +1072,7 @@ data TcSigInfo instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau + = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> ppr theta <+> ptext (sLit "=>") <+> ppr tau \end{code} \begin{code} @@ -1164,14 +1165,14 @@ isRestrictedGroup dflags binds sig_fn -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name patMonoBindsCtxt pat grhss - = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) + = hang (ptext (sLit "In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- sigContextsCtxt sig1 sig2 - = vcat [ptext SLIT("When matching the contexts of the signatures for"), + = vcat [ptext (sLit "When matching the contexts of the signatures for"), nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), ppr id2 <+> dcolon <+> ppr (idType id2)]), - ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + ptext (sLit "The signature contexts in a mutually recursive group should all be identical")] where id1 = sig_id sig1 id2 = sig_id sig2 @@ -1179,17 +1180,17 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- unboxedTupleErr name ty - = hang (ptext SLIT("Illegal binding of unboxed tuple")) + = hang (ptext (sLit "Illegal binding of unboxed tuple")) 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- restrictedBindCtxtErr binder_names - = hang (ptext SLIT("Illegal overloaded type signature(s)")) - 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, - ptext SLIT("that falls under the monomorphism restriction")]) + = hang (ptext (sLit "Illegal overloaded type signature(s)")) + 4 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names, + ptext (sLit "that falls under the monomorphism restriction")]) genCtxt binder_names - = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names missingSigWarn False name ty = return () missingSigWarn True name ty @@ -1197,6 +1198,6 @@ missingSigWarn True name ty ; let (env1, tidy_ty) = tidyOpenType env0 ty ; addWarnTcM (env1, mk_msg tidy_ty) } where - mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name), - sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]] + mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name), + sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]] \end{code}