[project @ 1998-02-10 14:15:51 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index ceb589f..3fe3ac5 100644 (file)
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -34,19 +34,15 @@ module TcMonad(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TcEnv  ( TcEnv, initEnv )
-import {-# SOURCE #-} TcType ( TcMaybe, TcTyVarSet )
+import {-# SOURCE #-} TcEnv  ( TcEnv )
 
 import Type            ( Type, GenType )
-import TyVar           ( TyVar, GenTyVar )
 import ErrUtils                ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts      ( opt_PprStyle_All, opt_PprUserLength )
+import CmdLineOpts      ( opt_PprStyle_All )
 
 import SST
 import Bag             ( Bag, emptyBag, isEmptyBag,
                          foldBag, unitBag, unionBags, snocBag )
-import FiniteMap       ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
-import Maybes          ( MaybeErr(..) )
 import SrcLoc          ( SrcLoc, noSrcLoc )
 import UniqFM          ( UniqFM, emptyUFM )
 import UniqSupply      ( UniqSupply, getUnique, getUniques, splitUniqSupply,
@@ -74,11 +70,14 @@ type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
 -- With a builtin polymorphic type for runSST the type for
 -- initTc should use  TcM s r  instead of  TcM RealWorld r 
 
+-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
+
 initTc :: UniqSupply
+       -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
        -> TcM RealWorld r
        -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
 
-initTc us do_this
+initTc us initenv do_this
   = runSST (
       newMutVarSST us                  `thenSST` \ us_var ->
       newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
@@ -87,7 +86,7 @@ initTc us do_this
           init_down = TcDown [] us_var
                             noSrcLoc
                             [] errs_var
-         init_env  = initEnv tvs_var
+         init_env  = initenv tvs_var
       in
       recoverSST
        (\_ -> returnSST Nothing)
@@ -279,7 +278,7 @@ addErrTc err_msg down env
     listNF_Tc ctxt down env    `thenSST` \ ctxt_msgs ->
     let
        err = addShortErrLocLine loc $
-             hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+             vcat (err_msg : ctxt_to_use ctxt_msgs)
     in
     writeMutVarSST errs_var (warns, errs `snocBag` err)        `thenSST_`
     returnSST ()
@@ -295,7 +294,7 @@ warnTc warn_if_true warn_msg down env
        listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
        let
            warn = addShortWarnLocLine loc $
-                  hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+                  vcat (warn_msg : ctxt_to_use ctxt_msgs)
        in
        writeMutVarSST errs_var (warns `snocBag` warn, errs)    `thenSST_`
        returnSST ()
@@ -559,9 +558,6 @@ arityErr kind name n m
   = hsep [ ppr name, ptext SLIT("should have"),
           n_arguments <> comma, text "but has been given", int m, char '.']
     where
-       errmsg = kind ++ " has too " ++ quantity ++ " arguments"
-       quantity | m < n     = "few"
-                | otherwise = "many"
        n_arguments | n == 0 = ptext SLIT("no arguments")
                    | n == 1 = ptext SLIT("1 argument")
                    | True   = hsep [int n, ptext SLIT("arguments")]