X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=1ff8b37c2aa2e59985bb3ef295ce342524f818a9;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=b23cf3782a2c9d206b2d23e47d01d0f2161f9464;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index b23cf37..1ff8b37 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,18 +1,28 @@
 \begin{code}
 module TcMonad(
-	TcM(..), NF_TcM(..), TcDown, TcEnv, 
+	TcType, TcMaybe(..), TcBox,
+	TcTauType, TcThetaType, TcRhoType,
+	TcTyVar, TcTyVarSet,
+	TcKind,
+
+	TcM, NF_TcM, TcDown, TcEnv, 
 	SST_R, FSST_R,
 
 	initTc,
 	returnTc, thenTc, thenTc_, mapTc, listTc,
 	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
-	mapBagTc, fixTc, tryTc,
+	mapBagTc, fixTc, tryTc, getErrsTc, 
+
+	uniqSMToTcM,
 
 	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, 
+	fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
+
 	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
 	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
-	failTc, warnTc, recoverTc, recoverNF_Tc,
+	failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+	addErrTcM, failWithTcM,
 
 	tcGetEnv, tcSetEnv,
 	tcGetDefaultTys, tcSetDefaultTys,
@@ -22,50 +32,71 @@ module TcMonad(
 	tcAddErrCtxtM, tcSetErrCtxtM,
 	tcAddErrCtxt, tcSetErrCtxt,
 
-	tcNewMutVar, tcReadMutVar, tcWriteMutVar,
+	tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
 
-	rn4MtoTcM,
-
-	TcError(..), TcWarning(..),
-	mkTcErr, arityErr,
-
-	-- For closure
-	MutableVar(..), _MutableArray
+	TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
+	arityErr
   ) where
 
-import Ubiq{-uitous-}
+#include "HsVersions.h"
 
-import TcMLoop		( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
+import {-# SOURCE #-} TcEnv  ( TcEnv )
 
-import Type		( Type(..), GenType )
-import TyVar		( TyVar(..), GenTyVar )
-import Usage		( Usage(..), GenUsage )
-import ErrUtils		( Error(..), Message(..), ErrCtxt(..),
-			  Warning(..) )
+import Type		( Type, GenType )
+import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+import CmdLineOpts      ( opt_PprStyle_Debug )
 
 import SST
---import RnMonad4
---LATER:import RnUtils		( GlobalNameMappers(..), GlobalNameMapper(..) )
-
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
+import Class		( Class )
+import Var		( GenTyVar )
+import VarEnv		( TyVarEnv, emptyVarEnv )
+import VarSet		( GenTyVarSet )
+import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+			  UniqSM, initUs )
+import SrcLoc		( SrcLoc, noSrcLoc )
 import FiniteMap	( FiniteMap, emptyFM )
---import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
-import ErrUtils		( Error(..) )
-import Maybes		( MaybeErr(..) )
---import Name		( Name )
-import SrcLoc		( SrcLoc, mkUnknownSrcLoc )
 import UniqFM		( UniqFM, emptyUFM )
-import UniqSupply	( UniqSupply, getUnique, getUniques, splitUniqSupply )
 import Unique		( Unique )
 import Util
-import Pretty
-import PprStyle		( PprStyle(..) )
+import Outputable
+
+import GlaExts		( State#, RealWorld )
+
 
 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` 
 \end{code}
 
 
+Types
+~~~~~
+\begin{code}
+type TcType s = GenType (TcBox s)	-- Used during typechecker
+	-- Invariant on ForAllTy in TcTypes:
+	-- 	forall a. T
+	-- a cannot occur inside a MutTyVar in T; that is,
+	-- T is "flattened" before quantifying over a
+
+type TcKind s = TcType s
+
+type TcThetaType s = [(Class, [TcType s])]
+type TcRhoType s   = TcType s		-- No ForAllTys
+type TcTauType s   = TcType s		-- No DictTys or ForAllTys
+
+type TcBox s = TcRef s (TcMaybe s)
+
+data TcMaybe s = UnBound
+	       | BoundTo (TcType s)
+
+-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
+-- because you get a synonym loop if you do!
+
+type TcTyVar s    = GenTyVar (TcBox s)
+type TcTyVarSet s = GenTyVarSet (TcBox s)
+\end{code}
+
+
 \section{TcM, NF_TcM: the type checker monads}
 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -75,24 +106,26 @@ type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
 \end{code}
 
 \begin{code}
--- With a builtin polymorphic type for _runSST the type for
--- initTc should use  TcM s r  instead of  TcM _RealWorld 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
-       -> TcM _RealWorld r
-       -> MaybeErr (r, Bag Warning)
-		   (Bag Error, Bag  Warning)
+       -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
+       -> TcM RealWorld r
+       -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
 
-initTc us do_this
-  = _runSST (
+initTc us initenv do_this
+  = runSST (
       newMutVarSST us 			`thenSST` \ us_var ->
       newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
       newMutVarSST emptyUFM		`thenSST` \ tvs_var ->
       let
           init_down = TcDown [] us_var
-			     mkUnknownSrcLoc
+			     noSrcLoc
 			     [] errs_var
-	  init_env  = initEnv tvs_var
+	  init_env  = initenv tvs_var
       in
       recoverSST
 	(\_ -> returnSST Nothing)
@@ -100,9 +133,7 @@ initTc us do_this
 	 returnFSST (Just res))
       					`thenSST` \ maybe_res ->
       readMutVarSST errs_var 		`thenSST` \ (warns,errs) ->
-      case (maybe_res, isEmptyBag errs) of
-        (Just res, True) -> returnSST (Succeeded (res, warns))
-	_ 		 -> returnSST (Failed (errs, warns))
+      returnSST (maybe_res, warns, errs)
     )
 
 thenNF_Tc :: NF_TcM s a
@@ -127,12 +158,25 @@ thenNF_Tc_ m k down env
 returnNF_Tc :: a -> NF_TcM s a
 returnNF_Tc v down env = returnSST v
 
+fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
+fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
+
 mapNF_Tc    :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 mapNF_Tc f []     = returnNF_Tc []
 mapNF_Tc f (x:xs) = f x			`thenNF_Tc` \ r ->
 		    mapNF_Tc f xs	`thenNF_Tc` \ rs ->
 		    returnNF_Tc (r:rs)
 
+foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
+foldrNF_Tc k z []     = returnNF_Tc z
+foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs	`thenNF_Tc` \r ->
+		        k x r
+
+foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
+foldlNF_Tc k z []     = returnNF_Tc z
+foldlNF_Tc k z (x:xs) = k z x		`thenNF_Tc` \r ->
+		        foldlNF_Tc k r xs
+
 listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
 listNF_Tc []     = returnNF_Tc []
 listNF_Tc (x:xs) = x			`thenNF_Tc` \ r ->
@@ -213,12 +257,20 @@ fixTc :: (a -> TcM s a) -> TcM s a
 fixTc m env down = fixFSST (\ loop -> m loop env down)
 \end{code}
 
-@forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
-This elegantly ensures that it can't zap any type variables that
-belong to the main thread.  We throw away any error messages!
+@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
+thread.  Ideally, this elegantly ensures that it can't zap any type
+variables that belong to the main thread.  But alas, the environment
+contains TyCon and Class environments that include (TcKind s) stuff,
+which is a Royal Pain.  By the time this fork stuff is used they'll
+have been unified down so there won't be any kind variables, but we
+can't express that in the current typechecker framework.
+
+So we compromise and use unsafeInterleaveSST.
+
+We throw away any error messages!
 
-\begin{pseudocode}
-forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+\begin{code}
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
   = 	-- Get a fresh unique supply
     readMutVarSST u_var		`thenSST` \ us ->
@@ -226,68 +278,86 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 	(us1, us2) = splitUniqSupply us
     in
     writeMutVarSST u_var us1	`thenSST_`
-    returnSST (_runSST (
-	newMutVarSST us2 			`thenSST` \ u_var'   ->
+    
+    unsafeInterleaveSST (
+	newMutVarSST us2 			`thenSST` \ us_var'   ->
       	newMutVarSST (emptyBag,emptyBag)	`thenSST` \ err_var' ->
       	newMutVarSST emptyUFM			`thenSST` \ tv_var'  ->
 	let
-            down' = TcDown deflts us_var src_loc err_cxt err_var'
-	    env'  = forkEnv env tv_var'
+            down' = TcDown deflts us_var' src_loc err_cxt err_var'
 	in
-	m down' env'
-
+	m down' env
 	-- ToDo: optionally dump any error messages
-    ))
-\end{pseudocode}
+    )
+\end{code}
 
-@forkTcDown@ makes a new "down" blob for a lazily-computed fork
-of the type checker.
 
-\begin{pseudocode}
-forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
-  = 	-- Get a fresh unique supply
-    readMutVarSST u_var		`thenSST` \ us ->
-    let
-	(us1, us2) = splitUniqSupply us
-    in
-    writeMutVarSST u_var us1	`thenSST_`
+Error handling
+~~~~~~~~~~~~~~
+\begin{code}
+getErrsTc :: NF_TcM s (Bag ErrMsg, Bag  WarnMsg)
+getErrsTc down env
+  = readMutVarSST errs_var 
+  where
+    errs_var = getTcErrs down
 
-	-- Make fresh MutVars for the unique supply and errors
-    newMutVarSST us2			`thenSST` \ u_var' ->
-    newMutVarSST (emptyBag, emptyBag)	`thenSST` \ err_var' ->
 
-	-- Done
-    returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
-\end{pseudocode}
+failTc :: TcM s a
+failTc down env
+  = failFSST ()
 
+failWithTc :: Message -> TcM s a			-- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 
-Error handling
-~~~~~~~~~~~~~~
-\begin{code}
-failTc :: Message -> TcM s a
-failTc err_msg down env
-  = readMutVarSST errs_var	`thenSST` \ (warns,errs) ->
-    listNF_Tc ctxt down env	`thenSST` \ ctxt_msgs ->
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+-- The 'M' variants do the TidyTypeEnv bit
+failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a	-- Add an error message and fail
+failWithTcM env_and_msg
+  = addErrTcM env_and_msg	`thenNF_Tc_`
+    failTc
+
+addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s ()	-- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+  = readMutVarSST errs_var		`thenSST` \ (warns,errs) ->
+    do_ctxt tidy_env ctxt down env	`thenSST` \ ctxt_msgs ->
     let
-	err = mkTcErr loc ctxt_msgs err_msg
+	err = addShortErrLocLine loc $
+	      vcat (err_msg : ctxt_to_use ctxt_msgs)
     in
     writeMutVarSST errs_var (warns, errs `snocBag` err)	`thenSST_`
-    failFSST ()
+    returnSST ()
   where
     errs_var = getTcErrs down
     ctxt     = getErrCtxt down
     loc      = getLoc down
 
+do_ctxt tidy_env [] down env
+  = returnSST []
+do_ctxt tidy_env (c:cs) down env
+  = c tidy_env down env 		`thenSST` \ (tidy_env', m) ->
+    do_ctxt tidy_env' cs down env	`thenSST` \ ms ->
+    returnSST (m:ms)
+
+-- warnings don't have an 'M' variant
 warnTc :: Bool -> Message -> NF_TcM s ()
-warnTc warn_if_true warn down env
+warnTc warn_if_true warn_msg down env
   = if warn_if_true then
-	readMutVarSST errs_var					`thenSST` \ (warns,errs) ->
+	readMutVarSST errs_var			`thenSST` \ (warns,errs) ->
+	do_ctxt emptyTidyEnv ctxt down env	`thenSST` \ ctxt_msgs ->
+	let
+	    warn = addShortWarnLocLine loc $
+	           vcat (warn_msg : ctxt_to_use ctxt_msgs)
+	in
 	writeMutVarSST errs_var (warns `snocBag` warn, errs) 	`thenSST_`
     	returnSST ()
     else
 	returnSST ()
   where
     errs_var = getTcErrs down
+    ctxt     = getErrCtxt down
+    loc      = getLoc down
 
 recoverTc :: TcM s r -> TcM s r -> TcM s r
 recoverTc recover m down env
@@ -297,18 +367,72 @@ recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
 recoverNF_Tc recover m down env
   = recoverSST (\ _ -> recover down env) (m down env)
 
+-- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
+-- If m fails then (checkNoErrsTc m) fails.
+-- If m succeeds, it checks whether m generated any errors messages
+--	(it might have recovered internally)
+-- 	If so, it fails too.
+-- Regardless, any errors generated by m are propagated to the enclosing
+-- context.
+
+checkNoErrsTc :: TcM s r -> TcM s r
+checkNoErrsTc m down env
+  = newMutVarSST (emptyBag,emptyBag)	`thenSST` \ m_errs_var ->
+    let
+	errs_var = getTcErrs down
+	propagate_errs _
+	 = readMutVarSST m_errs_var	`thenSST` \ (m_warns, m_errs) ->
+	   readMutVarSST errs_var	`thenSST` \ (warns, errs) ->
+	   writeMutVarSST errs_var (warns `unionBags` m_warns,
+				    errs  `unionBags` m_errs)	`thenSST_`
+	   failFSST()
+    in
+					    
+    recoverFSST propagate_errs $
+
+    m (setTcErrs down m_errs_var) env	`thenFSST` \ result ->
+
+	-- Check that m has no errors; if it has internal recovery
+	-- mechanisms it might "succeed" but having found a bunch of
+	-- errors along the way.
+    readMutVarSST m_errs_var		`thenSST` \ (m_warns, m_errs) ->
+    if isEmptyBag m_errs then
+	returnFSST result
+    else
+	failFSST ()	-- This triggers the recoverFSST
+
 -- (tryTc r m) tries m; if it succeeds it returns it,
 -- otherwise it returns r.  Any error messages added by m are discarded,
 -- whether or not m succeeds.
 tryTc :: TcM s r -> TcM s r -> TcM s r
 tryTc recover m down env
   = recoverFSST (\ _ -> recover down env) $
+
     newMutVarSST (emptyBag,emptyBag)	`thenSST` \ new_errs_var ->
+    m (setTcErrs down new_errs_var) env	`thenFSST` \ result ->
+
+	-- Check that m has no errors; if it has internal recovery
+	-- mechanisms it might "succeed" but having found a bunch of
+	-- errors along the way. If so we want tryTc to use 
+	-- "recover" instead
+    readMutVarSST new_errs_var		`thenSST` \ (_,errs) ->
+    if isEmptyBag errs then
+	returnFSST result
+    else
+	recover down env
+
+-- Run the thing inside, but throw away all its error messages.
+-- discardErrsTc :: TcM s r -> TcM s r
+-- discardErrsTc :: NF_TcM s r -> NF_TcM s r
+discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a)
+	      -> (TcDown s -> TcEnv s -> State# s -> a)
+discardErrsTc m down env
+  = newMutVarSST (emptyBag,emptyBag)	`thenSST` \ new_errs_var ->
     m (setTcErrs down new_errs_var) env
 
 checkTc :: Bool -> Message -> TcM s ()		-- Check that the boolean is true
 checkTc True  err = returnTc ()
-checkTc False err = failTc err
+checkTc False err = failWithTc err
 
 checkTcM :: Bool -> TcM s () -> TcM s ()	-- Check that the boolean is true
 checkTcM True  err = returnTc ()
@@ -316,7 +440,7 @@ checkTcM False err = err
 
 checkMaybeTc :: Maybe val -> Message -> TcM s val
 checkMaybeTc (Just val) err = returnTc val
-checkMaybeTc Nothing    err = failTc err
+checkMaybeTc Nothing    err = failWithTc err
 
 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
 checkMaybeTcM (Just val) err = returnTc val
@@ -326,13 +450,15 @@ checkMaybeTcM Nothing    err = err
 Mutable variables
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
+type TcRef s a = SSTRef s a
+
+tcNewMutVar :: a -> NF_TcM s (TcRef s a)
 tcNewMutVar val down env = newMutVarSST val
 
-tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
+tcWriteMutVar :: TcRef s a -> a -> NF_TcM s ()
 tcWriteMutVar var val down env = writeMutVarSST var val
 
-tcReadMutVar :: MutableVar s a -> NF_TcM s a
+tcReadMutVar :: TcRef s a -> NF_TcM s a
 tcReadMutVar var down env = readMutVarSST var
 \end{code}
 
@@ -343,7 +469,12 @@ Environment
 tcGetEnv :: NF_TcM s (TcEnv s)
 tcGetEnv down env = returnSST env
 
-tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv :: TcEnv s
+	  -> (TcDown s -> TcEnv s -> State# s -> b)
+	  ->  TcDown s -> TcEnv s -> State# s -> b
+-- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+-- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a
+
 tcSetEnv new_env m down old_env = m down new_env
 \end{code}
 
@@ -357,19 +488,27 @@ tcGetDefaultTys down env = returnSST (getDefaultTys down)
 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 
-tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+-- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+-- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
+tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
+		      -> (TcDown s -> env -> result)
 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 
 tcGetSrcLoc :: NF_TcM s SrcLoc
 tcGetSrcLoc down env = returnSST (getLoc down)
 
-tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message))
+			     -> TcM s a -> TcM s a
 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 
-tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
-tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
-tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
+tcSetErrCtxt, tcAddErrCtxt 
+	  :: Message
+	  -> (TcDown s -> TcEnv s -> State# s -> b)
+	  ->  TcDown s -> TcEnv s -> State# s -> b
+-- Usual thing
+tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
+tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 \end{code}
 
 
@@ -381,7 +520,7 @@ tcGetUnique down env
   = readMutVarSST u_var				`thenSST` \ uniq_supply ->
     let
       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniq			= getUnique uniq_s
+      uniq			= uniqFromSupply uniq_s
     in
     writeMutVarSST u_var new_uniq_supply		`thenSST_`
     returnSST uniq
@@ -393,12 +532,23 @@ tcGetUniques n down env
   = readMutVarSST u_var				`thenSST` \ uniq_supply ->
     let
       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniqs			= getUniques n uniq_s
+      uniqs			= uniqsFromSupply n uniq_s
     in
     writeMutVarSST u_var new_uniq_supply		`thenSST_`
     returnSST uniqs
   where
     u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM s a
+uniqSMToTcM m down env
+  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
+    let
+      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+    in
+    writeMutVarSST u_var new_uniq_supply		`thenSST_`
+    returnSST (initUs uniq_s m)
+  where
+    u_var = getUniqSupplyVar down
 \end{code}
 
 
@@ -410,16 +560,26 @@ data TcDown s
   = TcDown
 	[Type]				-- Types used for defaulting
 
-	(MutableVar s UniqSupply)	-- Unique supply
+	(TcRef s UniqSupply)	-- Unique supply
 
 	SrcLoc				-- Source location
 	(ErrCtxt s)			-- Error context
-	(MutableVar s (Bag Warning, 
-		       Bag Error))
-
-type ErrCtxt s = [NF_TcM s Message]	-- Innermost first.  Monadic so that we have a chance
-					-- to deal with bound type variables just before error
-					-- message construction
+	(TcRef s (Bag WarnMsg, 
+		  Bag ErrMsg))
+
+-- The TidyTypeEnv gives us a chance to tidy up the type,
+-- so it prints nicely in error messages
+type TidyTypeEnv s = (FiniteMap FastString Int,	-- Says what the 'next' unique to use
+						-- for this occname is
+		      TyVarEnv (TcType s))	-- Current mapping
+
+emptyTidyEnv :: TidyTypeEnv s
+emptyTidyEnv = (emptyFM, emptyVarEnv)
+
+type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message)]	
+			-- Innermost first.  Monadic so that we have a chance
+			-- to deal with bound type variables just before error
+			-- message construction
 \end{code}
 
 -- These selectors are *local* to TcMonad.lhs
@@ -442,29 +602,6 @@ getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 \end{code}
 
 
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)"
-{- LATER:
-rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
-
-rn4MtoTcM name_funs rn_action down env
-  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-    in
-    writeMutVarSST u_var new_uniq_supply	`thenSST_`
-    let
-	(rn_result, rn_errs)
-	  = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
-    in
-    returnSST (rn_result, rn_errs)
-  where
-    u_var = getUniqSupplyVar down
--}
-\end{code}
 
 
 TypeChecking Errors
@@ -474,26 +611,21 @@ TypeChecking Errors
 type TcError   = Message
 type TcWarning = Message
 
-mkTcErr :: SrcLoc 		-- Where
-	-> [Message] 		-- Context
-	-> Message 		-- What went wrong
-	-> TcError		-- The complete error report
-
-mkTcErr locn ctxt msg sty
-  = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
-    	 4 (ppAboves [msg sty | msg <- ctxt])
-
-
-arityErr kind name n m sty
-  = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
-		n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+		 | otherwise	      = takeAtMost 3 ctxt
+		 where
+		   takeAtMost :: Int -> [a] -> [a]
+     		   takeAtMost 0 ls = []
+     		   takeAtMost n [] = []
+     		   takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
+
+arityErr kind name n m
+  = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
+	   n_arguments <> comma, text "but has been given", int m]
     where
-	errmsg = kind ++ " has too " ++ quantity ++ " arguments"
-	quantity | m < n     = "few"
-		 | otherwise = "many"
-	n_arguments | n == 0 = ppStr "no arguments"
-		    | n == 1 = ppStr "1 argument"
-		    | True   = ppCat [ppInt n, ppStr "arguments"]
+	n_arguments | n == 0 = ptext SLIT("no arguments")
+		    | n == 1 = ptext SLIT("1 argument")
+		    | True   = hsep [int n, ptext SLIT("arguments")]
 \end{code}