X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=1b442afdda6cd743f0029bfc88b260413e372d79;hb=3ca33229d4b9c1ed2829318631e73e748154f3ff;hp=876564daad2815624243c9b4dd464db53384e358;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 876564d..1b442af 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,197 +1,193 @@
 \begin{code}
 module TcMonad(
-	TcM(..), NF_TcM(..), TcDown, TcEnv, 
-	SST_R, FSST_R,
+	TcType, 
+	TcTauType, TcPredType, TcThetaType, TcRhoType,
+	TcTyVar, TcTyVarSet,
+	TcKind,
+
+	TcM, NF_TcM, TcDown, TcEnv, 
 
 	initTc,
 	returnTc, thenTc, thenTc_, mapTc, listTc,
 	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
-	mapBagTc, fixTc, tryTc,
+	mapBagTc, fixTc, tryTc, tryTc_, getErrsTc, 
+	traceTc, ioToTc,
+
+	uniqSMToTcM,
+
+	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, 
+	fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
 
-	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_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, addInstErrTcM, failWithTcM,
 
 	tcGetEnv, tcSetEnv,
 	tcGetDefaultTys, tcSetDefaultTys,
 	tcGetUnique, tcGetUniques,
 
-	tcAddSrcLoc, tcGetSrcLoc,
+	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
 	tcAddErrCtxt, tcSetErrCtxt,
 
-	tcNewMutVar, tcReadMutVar, tcWriteMutVar,
-
-	rnMtoTcM,
+	tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
+	tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
 
-	TcError(..), TcWarning(..),
-	mkTcErr, arityErr,
+	InstOrigin(..), InstLoc, pprInstLoc, 
 
-	-- For closure
-	MutableVar(..), _MutableArray
+	TcError, TcWarning, TidyEnv, 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 SST
-import RnMonad		( RnM(..), RnDown, initRn, setExtraRn )
-import RnUtils		( RnEnv(..) )
+import HsSyn		( HsLit )
+import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
+import Type		( Type, Kind, PredType, ThetaType, RhoType, TauType,
+			)
+import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
+import CmdLineOpts      ( opt_PprStyle_Debug )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
+import Class		( Class )
+import Name		( Name )
+import Var		( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
+import VarEnv		( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
+import VarSet		( TyVarSet )
+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 BasicTypes	( Unused )
 import Util
-import Pretty
-import PprStyle		( PprStyle(..) )
+import Outputable
+import FastString	( FastString )
+
+import IOExts		( IORef, newIORef, readIORef, writeIORef,
+			  unsafeInterleaveIO, fixIO
+			)
+
 
 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` 
 \end{code}
 
 
+Types
+~~~~~
+\begin{code}
+type TcTyVar    = TyVar		-- Might be a mutable tyvar
+type TcTyVarSet = TyVarSet
+
+type TcType = Type 		-- A TcType can have mutable type variables
+	-- 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 TcPredType  = PredType
+type TcThetaType = ThetaType
+type TcRhoType   = RhoType
+type TcTauType   = TauType
+type TcKind      = TcType
+\end{code}
+
+
 \section{TcM, NF_TcM: the type checker monads}
 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 \begin{code}
-type NF_TcM s r =  TcDown s -> TcEnv s -> SST s r
-type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
+type NF_TcM s r =  TcDown -> TcEnv -> IO r	-- Can't raise UserError
+type TcM    s r =  TcDown -> TcEnv -> IO r	-- Can raise UserError
+	-- ToDo: nuke the 's' part
+	-- The difference between the two is
+	-- now for documentation purposes only
+
+type Either_TcM s r =  TcDown -> TcEnv -> IO r	-- Either NF_TcM or TcM
+	-- Used only in this file for type signatures which
+	-- have a part that's polymorphic in whether it's NF_TcM or TcM
+	-- E.g. thenNF_Tc
+
+type TcRef a = IORef a
 \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 
+-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
 
 initTc :: UniqSupply
-       -> TcM _RealWorld r
-       -> MaybeErr (r, Bag Warning)
-		   (Bag Error, Bag  Warning)
-
-initTc us do_this
-  = _runSST (
-      newMutVarSST us 			`thenSST` \ us_var ->
-      newMutVarSST (emptyBag,emptyBag)	`thenSST` \ errs_var ->
-      newMutVarSST emptyUFM		`thenSST` \ tvs_var ->
+       -> (TcRef (UniqFM a) -> TcEnv)
+       -> TcM s r
+       -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
+
+initTc us initenv do_this
+  = do {
+      us_var   <- newIORef us ;
+      errs_var <- newIORef (emptyBag,emptyBag) ;
+      tvs_var  <- newIORef emptyUFM ;
+
       let
           init_down = TcDown [] us_var
-			     mkUnknownSrcLoc
+			     noSrcLoc
 			     [] errs_var
-	  init_env  = initEnv tvs_var
-      in
-      recoverSST
-	(\_ -> returnSST Nothing)
-        (do_this init_down init_env `thenFSST` \ res ->
-	 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))
-    )
-
-thenNF_Tc :: NF_TcM s a
-	  -> (a -> TcDown s -> TcEnv s -> State# s -> b)
-	  -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b)    -> TcM s b
-
-thenNF_Tc m k down env
-  = m down env	`thenSST` \ r ->
-    k r down env
-
-thenNF_Tc_ :: NF_TcM s a
-	   -> (TcDown s -> TcEnv s -> State# s -> b)
-	   -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> TcM s b    -> TcM s b
-
-thenNF_Tc_ m k down env
-  = m down env	`thenSST_` k down env
-
-returnNF_Tc :: a -> NF_TcM s a
-returnNF_Tc v down env = returnSST v
+	  init_env  = initenv tvs_var
+      ;
 
-fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
-fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
+      maybe_res <- catch (do {  res <- do_this init_down init_env ;
+				return (Just res)})
+			 (\_ -> return Nothing) ;
+        
+      (warns,errs) <- readIORef errs_var ;
+      return (maybe_res, warns, errs)
+    }
 
-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)
+-- Monadic operations
 
-listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
-listNF_Tc []     = returnNF_Tc []
-listNF_Tc (x:xs) = x			`thenNF_Tc` \ r ->
-		   listNF_Tc xs		`thenNF_Tc` \ rs ->
-		   returnNF_Tc (r:rs)
-
-mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
-mapBagNF_Tc f bag
-  = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 -> 
-		        b2 `thenNF_Tc` \ r2 -> 
-		        returnNF_Tc (unionBags r1 r2))
-	    (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
-	    (returnNF_Tc emptyBag)
-	    bag
-
-mapAndUnzipNF_Tc    :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
-mapAndUnzipNF_Tc f []     = returnNF_Tc ([],[])
-mapAndUnzipNF_Tc f (x:xs) = f x				`thenNF_Tc` \ (r1,r2) ->
-			    mapAndUnzipNF_Tc f xs	`thenNF_Tc` \ (rs1,rs2) ->
-			    returnNF_Tc (r1:rs1, r2:rs2)
+returnNF_Tc :: a -> NF_TcM s a
+returnTc    :: a -> TcM s a
+returnTc v down env = return v
 
-thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
-thenTc m k down env
-  = m down env	`thenFSST` \ r ->
-    k r down env
+thenTc    :: TcM s a ->    (a -> TcM s b)        -> TcM s b
+thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
+thenTc m k down env = do { r <- m down env; k r down env }
 
-thenTc_ :: TcM s a -> TcM s b -> TcM s b
-thenTc_ m k down env
-  = m down env	`thenFSST_`  k down env
+thenTc_    :: TcM s a    -> TcM s b        -> TcM s b
+thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
+thenTc_ m k down env = do { m down env; k down env }
 
-returnTc :: a -> TcM s a
-returnTc val down env = returnFSST val
+listTc    :: [TcM s a]    -> TcM s [a]
+listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
+listTc []     = returnTc []
+listTc (x:xs) = x			`thenTc` \ r ->
+		listTc xs		`thenTc` \ rs ->
+		returnTc (r:rs)
 
-mapTc    :: (a -> TcM s b) -> [a]   -> TcM s [b]
+mapTc    :: (a -> TcM s b)    -> [a] -> TcM s [b]
+mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 mapTc f []     = returnTc []
 mapTc f (x:xs) = f x		`thenTc` \ r ->
 		 mapTc f xs	`thenTc` \ rs ->
 		 returnTc (r:rs)
 
-listTc    :: [TcM s a] -> TcM s [a]
-listTc []     = returnTc []
-listTc (x:xs) = x			`thenTc` \ r ->
-		listTc xs		`thenTc` \ rs ->
-		returnTc (r:rs)
-
-foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrTc    :: (a -> b -> TcM s b)    -> b -> [a] -> TcM s b
+foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
 foldrTc k z []     = returnTc z
 foldrTc k z (x:xs) = foldrTc k z xs	`thenTc` \r ->
 		     k x r
 
-foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlTc    :: (a -> b -> TcM s a)    -> a -> [b] -> TcM s a
+foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
 foldlTc k z []     = returnTc z
 foldlTc k z (x:xs) = k z x		`thenTc` \r ->
 		     foldlTc k r xs
 
-mapAndUnzipTc    :: (a -> TcM s (b,c)) -> [a]   -> TcM s ([b],[c])
+mapAndUnzipTc    :: (a -> TcM s (b,c))    -> [a]   -> TcM s ([b],[c])
+mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
 mapAndUnzipTc f []     = returnTc ([],[])
 mapAndUnzipTc f (x:xs) = f x			`thenTc` \ (r1,r2) ->
 			 mapAndUnzipTc f xs	`thenTc` \ (rs1,rs2) ->
@@ -203,7 +199,8 @@ mapAndUnzip3Tc f (x:xs) = f x			`thenTc` \ (r1,r2,r3) ->
 			  mapAndUnzip3Tc f xs	`thenTc` \ (rs1,rs2,rs3) ->
 			  returnTc (r1:rs1, r2:rs2, r3:rs3)
 
-mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagTc    :: (a -> TcM s b)    -> Bag a -> TcM s (Bag b)
+mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
 mapBagTc f bag
   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 -> 
 		        b2 `thenTc` \ r2 -> 
@@ -212,106 +209,100 @@ mapBagTc f bag
 	    (returnTc emptyBag)
 	    bag
 
-fixTc :: (a -> TcM s a) -> TcM s a
-fixTc m env down = fixFSST (\ loop -> m loop env down)
+fixTc    :: (a -> TcM s a)    -> TcM s a
+fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
+fixTc m env down = fixIO (\ loop -> m loop env down)
+
+recoverTc    :: TcM s r -> TcM s r -> TcM s r
+recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
+recoverTc recover m down env
+  = catch (m down env) (\ _ -> recover down env)
+
+returnNF_Tc 	 = returnTc
+thenNF_Tc   	 = thenTc
+thenNF_Tc_  	 = thenTc_
+fixNF_Tc    	 = fixTc
+recoverNF_Tc	 = recoverTc
+mapNF_Tc    	 = mapTc
+foldrNF_Tc  	 = foldrTc
+foldlNF_Tc  	 = foldlTc
+listNF_Tc   	 = listTc
+mapAndUnzipNF_Tc = mapAndUnzipTc
+mapBagNF_Tc      = mapBagTc
 \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 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.
 
-\begin{pseudocode}
-forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+So we compromise and use unsafeInterleaveSST.
+
+We throw away any error messages!
+
+\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 ->
-    let
-	(us1, us2) = splitUniqSupply us
-    in
-    writeMutVarSST u_var us1	`thenSST_`
-    returnSST (_runSST (
-	newMutVarSST us2 			`thenSST` \ u_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'
-	in
-	m down' env'
-
-	-- ToDo: optionally dump any error messages
-    ))
-\end{pseudocode}
-
-@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_`
-
-	-- 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}
-
-
-Error handling
-~~~~~~~~~~~~~~
+  = do
+	-- Get a fresh unique supply
+    	us <- readIORef u_var
+	let (us1, us2) = splitUniqSupply us
+	writeIORef u_var us1
+    
+	unsafeInterleaveIO (do {
+		us_var'  <- newIORef us2 ;
+	      	err_var' <- newIORef (emptyBag,emptyBag) ;
+      		tv_var'  <- newIORef emptyUFM ;
+		let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
+		m down' env
+			-- ToDo: optionally dump any error messages
+		})
+\end{code}
+
 \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 ->
-    let
-	err = mkTcErr loc ctxt_msgs err_msg
-    in
-    writeMutVarSST errs_var (warns, errs `snocBag` err)	`thenSST_`
-    failFSST ()
-  where
-    errs_var = getTcErrs down
-    ctxt     = getErrCtxt down
-    loc      = getLoc down
+traceTc :: SDoc -> NF_TcM s ()
+traceTc doc down env = printErrs doc
 
-warnTc :: Bool -> Message -> NF_TcM s ()
-warnTc warn_if_true warn down env
-  = if warn_if_true then
-	readMutVarSST errs_var					`thenSST` \ (warns,errs) ->
-	writeMutVarSST errs_var (warns `snocBag` warn, errs) 	`thenSST_`
-    	returnSST ()
-    else
-	returnSST ()
-  where
-    errs_var = getTcErrs down
+ioToTc :: IO a -> NF_TcM s a
+ioToTc io down env = io
+\end{code}
 
-recoverTc :: TcM s r -> TcM s r -> TcM s r
-recoverTc recover m down env
-  = recoverFSST (\ _ -> recover down env) (m down env)
 
-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)
+%************************************************************************
+%*									*
+\subsection{Error handling}
+%*									*
+%************************************************************************
 
--- (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
+\begin{code}
+getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+  = readIORef (getTcErrs down)
+
+failTc :: TcM s a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = IOERROR (userError "Typecheck failed")
+
+failWithTc :: Message -> TcM s a			-- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM s a	-- Add an error message and fail
+failWithTcM env_and_msg
+  = addErrTcM env_and_msg	`thenNF_Tc_`
+    failTc
 
 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 ()
@@ -319,34 +310,159 @@ 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
 checkMaybeTcM Nothing    err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM s ()	-- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+  = add_err_tcm tidy_env err_msg ctxt loc down env
+  where
+    ctxt     = getErrCtxt down
+    loc      = getLoc down
+
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s ()	-- Add an error message but don't fail
+addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
+  = add_err_tcm tidy_env err_msg full_ctxt loc down env
+  where
+    full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
+
+add_err_tcm tidy_env err_msg ctxt loc down env
+  = do
+	(warns, errs) <- readIORef errs_var
+	ctxt_msgs     <- do_ctxt tidy_env ctxt down env
+	let err = addShortErrLocLine loc $
+		  vcat (err_msg : ctxt_to_use ctxt_msgs)
+	writeIORef errs_var (warns, errs `snocBag` err)
+  where
+    errs_var = getTcErrs down
+
+do_ctxt tidy_env [] down env
+  = return []
+do_ctxt tidy_env (c:cs) down env
+  = do 
+	(tidy_env', m) <- c tidy_env down env
+	ms	       <- do_ctxt tidy_env' cs down env
+	return (m:ms)
+
+-- warnings don't have an 'M' variant
+warnTc :: Bool -> Message -> NF_TcM s ()
+warnTc warn_if_true warn_msg down env
+  | warn_if_true 
+  = do
+	(warns,errs) <- readIORef errs_var
+	ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env	
+	let warn = addShortWarnLocLine loc $
+	           vcat (warn_msg : ctxt_to_use ctxt_msgs)
+	writeIORef errs_var (warns `snocBag` warn, errs)
+  | otherwise
+  = return ()
+  where
+    errs_var = getTcErrs down
+    ctxt     = getErrCtxt down
+    loc      = getLoc down
+
+-- (tryTc r m) succeeds if m succeeds and generates no errors
+-- If m fails then r is invoked, passing the warnings and errors from m
+-- If m succeeds, (tryTc r m) checks whether m generated any errors messages
+--	(it might have recovered internally)
+-- 	If so, then r is invoked, passing the warnings and errors from m
+
+tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r)	-- Recovery action
+      -> TcM s r				-- Thing to try
+      -> TcM s r
+tryTc recover main down env
+  = do 
+	m_errs_var <- newIORef (emptyBag,emptyBag)
+	catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
+  where
+    my_recover m_errs_var
+      = do warns_and_errs <- readIORef m_errs_var
+	   recover warns_and_errs down env
+
+    my_main m_errs_var
+       = do result <- main (setTcErrs down m_errs_var) env
+
+		-- 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.
+	    (m_warns, m_errs) <- readIORef m_errs_var
+	    if isEmptyBag m_errs then
+		return result
+	      else
+		give_up		-- This triggers the catch
+
+
+-- (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 main
+  = tryTc my_recover main
+  where
+    my_recover (m_warns, m_errs) down env
+	= do (warns, errs)     <- readIORef errs_var
+	     writeIORef errs_var (warns `unionBags` m_warns,
+				  errs  `unionBags` m_errs)
+	     give_up
+	where
+	  errs_var = getTcErrs down
+
+
+-- (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 main
+  = tryTc my_recover main
+  where
+    my_recover warns_and_errs = recover
+
+-- (discardErrsTc m) runs m, but throw away all its error messages.
+discardErrsTc :: Either_TcM s r -> Either_TcM s r
+discardErrsTc main down env
+  = do new_errs_var <- newIORef (emptyBag,emptyBag)
+       main (setTcErrs down new_errs_var) env
 \end{code}
 
 Mutable variables
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
-tcNewMutVar val down env = newMutVarSST val
+tcNewMutVar :: a -> NF_TcM s (TcRef a)
+tcNewMutVar val down env = newIORef val
+
+tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeIORef var val
+
+tcReadMutVar :: TcRef a -> NF_TcM s a
+tcReadMutVar var down env = readIORef var
+
+tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewMutTyVar name kind down env = newMutTyVar name kind
+
+tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewSigTyVar name kind down env = newSigTyVar name kind
 
-tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
-tcWriteMutVar var val down env = writeMutVarSST var val
+tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 
-tcReadMutVar :: MutableVar s a -> NF_TcM s a
-tcReadMutVar var down env = readMutVarSST var
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
+tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 \end{code}
 
 
 Environment
 ~~~~~~~~~~~
 \begin{code}
-tcGetEnv :: NF_TcM s (TcEnv s)
-tcGetEnv down env = returnSST env
+tcGetEnv :: NF_TcM s TcEnv
+tcGetEnv down env = return env
 
-tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
 tcSetEnv new_env m down old_env = m down new_env
 \end{code}
 
@@ -355,24 +471,29 @@ Source location
 ~~~~~~~~~~~~~~~
 \begin{code}
 tcGetDefaultTys :: NF_TcM s [Type]
-tcGetDefaultTys down env = returnSST (getDefaultTys down)
+tcGetDefaultTys down env = return (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 -> Either_TcM s a -> Either_TcM s a
 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 
 tcGetSrcLoc :: NF_TcM s SrcLoc
-tcGetSrcLoc down env = returnSST (getLoc down)
+tcGetSrcLoc down env = return (getLoc down)
 
-tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
+tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
+
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, 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 -> Either_TcM s r -> Either_TcM s r
+-- 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,25 +502,30 @@ Unique supply
 \begin{code}
 tcGetUnique :: NF_TcM s Unique
 tcGetUnique down env
-  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniq			= getUnique uniq_s
-    in
-    writeMutVarSST u_var new_uniq_supply		`thenSST_`
-    returnSST uniq
+  = do  uniq_supply <- readIORef u_var
+    	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+	    uniq		      = uniqFromSupply uniq_s
+	writeIORef u_var new_uniq_supply
+	return uniq
   where
     u_var = getUniqSupplyVar down
 
 tcGetUniques :: Int -> NF_TcM s [Unique]
 tcGetUniques n down env
-  = readMutVarSST u_var				`thenSST` \ uniq_supply ->
-    let
-      (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-      uniqs			= getUniques n uniq_s
-    in
-    writeMutVarSST u_var new_uniq_supply		`thenSST_`
-    returnSST uniqs
+  = do	uniq_supply <- readIORef u_var
+	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+	    uniqs		      = uniqsFromSupply n uniq_s
+	writeIORef u_var new_uniq_supply
+	return uniqs
+  where
+    u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM s a
+uniqSMToTcM m down env
+  = do	uniq_supply <- readIORef u_var
+	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+	writeIORef u_var new_uniq_supply
+	return (initUs_ uniq_s m)
   where
     u_var = getUniqSupplyVar down
 \end{code}
@@ -409,20 +535,21 @@ tcGetUniques n down env
 %~~~~~~~~~~~~~~~
 
 \begin{code}
-data TcDown s
+data TcDown
   = TcDown
-	[Type]				-- Types used for defaulting
+	[Type]			-- Types used for defaulting
 
-	(MutableVar s UniqSupply)	-- Unique supply
+	(TcRef UniqSupply)	-- Unique supply
 
-	SrcLoc				-- Source location
-	(ErrCtxt s)			-- Error context
-	(MutableVar s (Bag Warning, 
-		       Bag Error))
+	SrcLoc			-- Source location
+	ErrCtxt			-- Error context
+	(TcRef (Bag WarnMsg, 
+		  Bag ErrMsg))
 
-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
+type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, 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
@@ -445,26 +572,6 @@ getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 \end{code}
 
 
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
-
-rnMtoTcM rn_env 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_warns)
-	  = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action
-    in
-    returnSST (rn_result, rn_errs)
-  where
-    u_var = getUniqSupplyVar down
-\end{code}
 
 
 TypeChecking Errors
@@ -474,26 +581,123 @@ TypeChecking Errors
 type TcError   = Message
 type TcWarning = Message
 
-mkTcErr :: SrcLoc 		-- Where
-	-> [Message] 		-- Context
-	-> Message 		-- What went wrong
-	-> TcError		-- The complete error report
+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
+	n_arguments | n == 0 = ptext SLIT("no arguments")
+		    | n == 1 = ptext SLIT("1 argument")
+		    | True   = hsep [int n, ptext SLIT("arguments")]
+\end{code}
+
 
-mkTcErr locn ctxt msg sty
-  = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
-    	 4 (ppAboves [msg sty | msg <- ctxt])
 
+%************************************************************************
+%*									*
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%*									*
+%************************************************************************
 
-arityErr kind name n m sty
-  = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
-		n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
-    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"]
-\end{code}
+The @InstOrigin@ type gives information about where a dictionary came from.
+This is important for decent error message reporting because dictionaries
+don't appear in the original source code.  Doubtless this type will evolve...
+
+It appears in TcMonad because there are a couple of error-message-generation
+functions that deal with it.
+
+\begin{code}
+type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+
+data InstOrigin
+  = OccurrenceOf Id		-- Occurrence of an overloaded identifier
+
+  | RecordUpdOrigin
+
+  | DataDeclOrigin		-- Typechecking a data declaration
+
+  | InstanceDeclOrigin		-- Typechecking an instance decl
+
+  | LiteralOrigin HsLit		-- Occurrence of a literal
 
+  | PatOrigin RenamedPat
 
+  | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+
+  | SignatureOrigin		-- A dict created from a type signature
+  | Rank2Origin			-- A dict created when typechecking the argument
+				-- of a rank-2 typed function
+
+  | DoOrigin			-- The monad for a do expression
+
+  | ClassDeclOrigin		-- Manufactured during a class decl
+
+  | InstanceSpecOrigin	Class	-- in a SPECIALIZE instance pragma
+			Type
+
+	-- When specialising instances the instance info attached to
+	-- each class is not yet ready, so we record it inside the
+	-- origin information.  This is a bit of a hack, but it works
+	-- fine.  (Patrick is to blame [WDP].)
+
+  | ValSpecOrigin	Name	-- in a SPECIALIZE pragma for a value
+
+	-- Argument or result of a ccall
+	-- Dictionaries with this origin aren't actually mentioned in the
+	-- translated term, and so need not be bound.  Nor should they
+	-- be abstracted over.
+
+  | CCallOrigin		String			-- CCall label
+			(Maybe RenamedHsExpr)	-- Nothing if it's the result
+						-- Just arg, for an argument
+
+  | LitLitOrigin	String	-- the litlit
+
+  | UnknownOrigin	-- Help! I give up...
+\end{code}
+
+\begin{code}
+pprInstLoc :: InstLoc -> SDoc
+pprInstLoc (orig, locn, ctxt)
+  = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
+  where
+    pp_orig (OccurrenceOf id)
+      	= hsep [ptext SLIT("use of"), quotes (ppr id)]
+    pp_orig (LiteralOrigin lit)
+	= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+    pp_orig (PatOrigin pat)
+	= hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
+    pp_orig (InstanceDeclOrigin)
+	=  ptext SLIT("an instance declaration")
+    pp_orig (ArithSeqOrigin seq)
+	= hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+    pp_orig (SignatureOrigin)
+	=  ptext SLIT("a type signature")
+    pp_orig (Rank2Origin)
+	=  ptext SLIT("a function with an overloaded argument type")
+    pp_orig (DoOrigin)
+	=  ptext SLIT("a do statement")
+    pp_orig (ClassDeclOrigin)
+	=  ptext SLIT("a class declaration")
+    pp_orig (InstanceSpecOrigin clas ty)
+	= hsep [text "a SPECIALIZE instance pragma; class",
+	        quotes (ppr clas), text "type:", ppr ty]
+    pp_orig (ValSpecOrigin name)
+	= hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
+    pp_orig (CCallOrigin clabel Nothing{-ccall result-})
+	= hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
+    pp_orig (CCallOrigin clabel (Just arg_expr))
+	= hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, 
+		text "namely", quotes (ppr arg_expr)]
+    pp_orig (LitLitOrigin s)
+	= hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
+    pp_orig (UnknownOrigin)
+	= ptext SLIT("...oops -- I don't know where the overloading came from!")
+\end{code}