Don't import FastString in HsVersions.h

[ghc-hetmet.git] / compiler / typecheck / TcBinds.lhs

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index db1a37a..d9f5587 100644 (file)
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -56,6 +56,9 @@ import List
 import Util
 import BasicTypes
 import Outputable
+import FastString
+
+import Control.Monad
 \end{code}
 
 
@@ -141,11 +144,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 
@@ -426,10 +429,8 @@ tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
 tcSpecPrag poly_id hs_ty inl
   = do { let name = idName poly_id
        ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
-       ; (co_fn, lie) <- getLIE (tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty)
-       ; extendLIEs lie
-       ; let const_dicts = map instToId lie
-       ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+       ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
+       ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
        -- Most of the work of specialisation is done by 
        -- the desugarer, guided by the SpecPrag
   
@@ -577,9 +578,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) }
 
@@ -745,7 +746,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]
@@ -801,7 +802,7 @@ unifyCtxts (sig1 : sigs)    -- Argument is always non-empty
 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
@@ -813,15 +814,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))       $
        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]
@@ -1200,5 +1201,5 @@ missingSigWarn True  name 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]]
+                     sep [ptext SLIT("Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]]
 \end{code}