X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=dceff864fb232890019ce1f791f05c2b3c31f034;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=dc947dce3be3336918882e4132414f00664a22f7;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index dc947dc..dceff86 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,729 +1,743 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
-
 \begin{code}
-#include "HsVersions.h"
+module TcMonad(
+	TcM, NF_TcM, TcDown, TcEnv, 
 
-module TcMonad (
-	TcM(..), TcResult{-abstract-},
-	thenTc, thenTc_, returnTc, failTc, checkTc,
-	listTc, mapTc, mapAndUnzipTc,
-	fixTc, foldlTc, initTc,
-	recoverTc, recoverQuietlyTc,
-
-	NF_TcM(..),
-	thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
-	fixNF_Tc, noFailTc,
-
-	Baby_TcM(..), Baby_TcResult{-abstract-},
-	returnB_Tc, thenB_Tc, thenB_Tc_,
-	failB_Tc, recoverIgnoreErrorsB_Tc,
-	fixB_Tc, mapB_Tc,
-	babyTcMtoTcM, babyTcMtoNF_TcM,
-	getUniqueB_Tc, getUniquesB_Tc,
-	addSrcLocB_Tc, getSrcLocB_Tc,
-	getSwitchCheckerB_Tc, checkB_Tc,
-	uniqSMtoBabyTcM,
-
-	getSwitchCheckerTc,
-	getDefaultingTys, setDefaultingTys,
-	getUniquesTc, getUniqueTc,
-	rn4MtoTcM,
-
-	getTyVarUniquesTc, getTyVarUniqueTc,
-
-	applyTcSubstToTy, applyTcSubstToTys,
---UNUSED:	applyTcSubstToThetaTy,
-	applyTcSubstToTyVar, applyTcSubstToTyVars,
-	applyTcSubstToId,
-	applyTcSubstToInst, applyTcSubstToInsts,
-	extendSubstTc, pruneSubstTc,
-
-	addSrcLocTc, getSrcLocTc,
-	checkMaybeTc,	 checkMaybesTc,
-	checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
-
-	lookupInst_Tc, lookupNoBindInst_Tc,
-
-	-- and to make the interface self-sufficient ...
-	UniqueSupply, SplitUniqSupply,
-	Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
-	PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
-	Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
-	UnifyErrContext, Unique, Expr,
-	TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
-	GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
-	GlobalNameFun(..), Name, ProtoName
-
-	IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
-	IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToId)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
-	IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
-    ) where
-
-import AbsSyn
-import AbsUniType	( TyVar, TyVarTemplate, TyCon, Class, UniType,
-			  TauType(..), ThetaType(..), SigmaType(..)
-			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
-			)
-import Bag		( Bag, snocBag, emptyBag, isEmptyBag )
-import CmdLineOpts	( GlobalSwitch )
-import Errors		( noInstanceErr, unifyErr, pprBagOfErrors,
-			  Error(..), UnifyErrInfo(..), UnifyErrContext(..)
-			)
-import FiniteMap	( emptyFM, FiniteMap )
-import Id		( applySubstToId )
-import Inst		( applySubstToInst )
-import InstEnv		( lookupInst, lookupNoBindInst, Inst )
-import Maybes		( Maybe(..), MaybeErr(..) )
-import Pretty
-import RenameMonad4	( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
-import SrcLoc		( mkUnknownSrcLoc )
-import Subst
-import Unify
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
-\end{code}
+	initTc,
+	returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
+	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
+	mapBagTc, fixTc, tryTc, tryTc_, getErrsTc, 
+	traceTc, ioToTc,
 
-%************************************************************************
-%*									*
-\subsection[TcM-TcM]{Plain @TcM@ monadery}
-%*									*
-%************************************************************************
+	uniqSMToTcM,
 
-The following @TcM@ is of the garden variety which can fail, and does
-as soon as possible.
+	returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, 
+	fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
 
-\begin{code}
--- internal use only...
-type InTcM output
-	=  (GlobalSwitch -> Bool)	-- so we can chk cmd-line switches
-	-> [UniType]			-- types used for defaulting; down only
-	-> Subst			-- substitution; threaded
-	-> SplitUniqSupply		-- threaded
-	-> Bag Error			-- threaded
-	-> SrcLoc			-- only passed downwards
-	-> output
-
-data TcResult result
-  = TcSucceeded result
-		Subst
-		(Bag Error)
-  | TcFailed	Subst
-		(Bag Error)
-
-type TcM result
-	= InTcM (TcResult result)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenTc #-}
-{-# INLINE thenTc_ #-}
-{-# INLINE returnTc #-}
-#endif
-
-thenTc  :: TcM a -> (a -> TcM b) -> TcM b
-thenTc_ :: TcM a -> TcM b -> TcM b
-
-thenTc expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-      TcFailed subst errs -> TcFailed subst errs
-      TcSucceeded result subst2 errs2
-	-> cont result sw_chkr dtys subst2 s2 errs2 src_loc
-    }
+	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
-thenTc_ expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-      TcFailed subst errs -> TcFailed subst errs
-      TcSucceeded _ subst2 errs2
-	-> cont sw_chkr dtys subst2 s2 errs2 src_loc
-    }
+	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
+	failTc, failWithTc, addErrTc, addErrsTc, warnTc, 
+	recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+	addErrTcM, addInstErrTcM, failWithTcM,
 
-returnTc :: a -> TcM a
-returnTc result sw_chkr dtys subst us errs src_loc
-  = TcSucceeded result subst errs
+	tcGetEnv, tcSetEnv,
+	tcGetDefaultTys, tcSetDefaultTys,
+	tcGetUnique, tcGetUniques, 
+	doptsTc, getDOptsTc,
 
-failTc err sw_chkr dtys subst us errs src_loc
-  = TcFailed subst (errs `snocBag` err)
-\end{code}
-
-@recoverTc@ recovers from an error, by providing a value to use
-instead.  It is also lazy, in that it always succeeds immediately; the
-thing inside is only even looked at when you pull on the errors, or on
-the value returned.
+	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
+	tcAddErrCtxtM, tcSetErrCtxtM,
+	tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
 
-@recoverQuietlyTc@ doesn't even report the errors found---it is used
-when looking at pragmas.
+	tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
+	tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
 
-\begin{code}
-recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
+	InstOrigin(..), InstLoc, pprInstLoc, 
 
-recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
-  = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
-      TcSucceeded result subst_out errs_out -> 
-	(result, combineSubstUndos subst_out, errs_out)
+	TcError, TcWarning, TidyEnv, emptyTidyEnv,
+	arityErr
+  ) where
 
-      TcFailed subst_out errs_out ->
-	(use_this_if_err, undoSubstUndos subst_out, errs_out)
-	  -- Note that we return the *undone* substitution
-	  -- and the *incoming* UniqueSupply
-
-recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
-  = (r2, s2, e2)
-  where
-    (r2, s2, e2)
-      = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
-          TcSucceeded result subst_out errs_out -> 
-	    (result, combineSubstUndos subst_out, errs_out)
-
-          TcFailed subst_out errs_out ->
-	    (use_this_if_err, undoSubstUndos subst_out, errs_in)
-	  -- Note that we return the *undone* substitution,
-	  -- the *incoming* UniqueSupply, and the *incoming* errors
-\end{code}
-
-The following @TcM@ checks a condition and fails with the given error
-message.
+#include "HsVersions.h"
 
-\begin{code}
-checkTc :: Bool -> Error -> TcM ()
-
-checkTc True  err = failTc err
-checkTc False err = returnTc ()
-
-listTc :: [TcM a] -> TcM [a]
-
-listTc [] = returnTc []
-listTc (x:xs)
- = x		`thenTc` \ r ->
-   listTc xs	`thenTc` \ rs ->
-   returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs)
- = f x		`thenTc` \ r ->
-   mapTc f xs	`thenTc` \ rs ->
-   returnTc (r:rs)
-
-mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
-
-mapAndUnzipTc f [] = returnTc ([], [])
-mapAndUnzipTc f (x:xs)
- = f x			`thenTc` \ (r1,  r2)  ->
-   mapAndUnzipTc f xs	`thenTc` \ (rs1, rs2) ->
-   returnTc (r1:rs1, r2:rs2)
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlTc f a []	   = returnTc a
-foldlTc f a (b:bs) = f a b	`thenTc` \ a2 ->
-		     foldlTc f a2 bs
-
-fixTc :: (x -> TcM x) -> TcM x
-fixTc m sw_chkr dtys subst us errs src_loc
-  = lim
-  where
-    lim    = m result sw_chkr dtys subst us errs src_loc
-    result = case lim of
-	       TcSucceeded result _ _ -> result
-#ifdef DEBUG
-	       TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
-#endif
-\end{code}
+import {-# SOURCE #-} TcEnv  ( TcEnv )
+
+import HsLit		( HsOverLit )
+import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
+import TcType		( Type, Kind, TyVarDetails )
+import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+
+import Bag		( Bag, emptyBag, isEmptyBag,
+			  foldBag, unitBag, unionBags, snocBag )
+import Class		( Class )
+import Name		( Name )
+import Var		( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
+import VarEnv		( TidyEnv, emptyTidyEnv )
+import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply, 
+			  splitUniqSupply, mkSplitUniqSupply,
+			  UniqSM, initUs_ )
+import SrcLoc		( SrcLoc, noSrcLoc )
+import BasicTypes	( IPName )
+import UniqFM		( emptyUFM )
+import Unique		( Unique )
+import CmdLineOpts
+import Outputable
+
+import IOExts		( IORef, newIORef, readIORef, writeIORef,
+			  unsafeInterleaveIO, fixIO
+			)
 
-And the machinery to start things up:
 
-\begin{code}
-aRRAY_SIZE :: Int
-aRRAY_SIZE  = 511
-
-initTc	:: (GlobalSwitch -> Bool)
-	-> SplitUniqSupply
-	-> TcM result
-	-> MaybeErr result (Bag Error)
-
-initTc sw_chkr us tc
-  = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
-      TcFailed _ errs -> Failed errs
-      TcSucceeded result subst2 errs
-	-> if isEmptyBag errs then
-	      Succeeded result
-	   else
-	      Failed errs
-
-init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` 
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
+\subsection{The main monads: TcM, NF_TcM}
 %*									*
 %************************************************************************
 
-This is a no-fail version of a TcM.
-
 \begin{code}
--- ToDo: re-order fields to match TcM?
-type NF_TcM result = InTcM (result, Subst, Bag Error)
+type NF_TcM r =  TcDown -> TcEnv -> IO r	-- Can't raise UserError
+type TcM    r =  TcDown -> TcEnv -> IO r	-- Can raise UserError
 
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenNF_Tc #-}
-{-# INLINE thenLazilyNF_Tc #-}
-{-# INLINE returnNF_Tc #-}
-#endif
+type Either_TcM 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
 
-thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
--- ...Lazily... is purely a performance thing (WDP 95/09)
+type TcRef a = IORef a
 \end{code}
 
-In particular, @thenNF_Tc@ has all of these types:
-\begin{pseudocode}
-thenNF_Tc :: NF_TcM a -> (a -> TcM b)	 -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
-\end{pseudocode}
-
 \begin{code}
-thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
-  = case splitUniqSupply us	    of { (s1, s2) ->
-    case (expr sw_chkr dtys subst s1 errs src_loc) of
-     (result, subst2, errs2)
-       -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
-    }
 
-thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
-  = let
-	(s1, s2) = splitUniqSupply us
-    in
-    case (expr sw_chkr dtys subst s1 errs src_loc) of {
-     (result, subst2, errs2)
-       -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
+initTc :: DynFlags 
+       -> TcEnv
+       -> TcM r
+       -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
+
+initTc dflags tc_env do_this
+  = do {
+      us       <- mkSplitUniqSupply 'a' ;
+      us_var   <- newIORef us ;
+      errs_var <- newIORef (emptyBag,emptyBag) ;
+      tvs_var  <- newIORef emptyUFM ;
+
+      let
+          init_down = TcDown { tc_dflags = dflags, tc_def = [],
+			       tc_us = us_var, tc_loc = noSrcLoc,
+			       tc_ctxt = [], tc_errs = errs_var }
+      ;
+
+      maybe_res <- catch (do {  res <- do_this init_down tc_env ;
+				return (Just res)})
+			 (\_ -> return Nothing) ;
+        
+      (warns,errs) <- readIORef errs_var ;
+      return (maybe_res, (warns, errs))
     }
 
+-- Monadic operations
+
 returnNF_Tc :: a -> NF_TcM a
-returnNF_Tc result sw_chkr dtys subst us errs src_loc
-  = (result, subst, errs)
+returnTc    :: a -> TcM a
+returnTc v down env = return v
 
+thenTc    :: TcM a ->    (a -> TcM b)        -> TcM b
+thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
+thenTc m k down env = do { r <- m down env; k r down env }
+
+thenTc_    :: TcM a    -> TcM b        -> TcM b
+thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
+thenTc_ m k down env = do { m down env; k down env }
+
+listTc    :: [TcM a]    -> TcM [a]
 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs)
-  = x			`thenNF_Tc` \ r ->
-    listNF_Tc xs	`thenNF_Tc` \ rs ->
-    returnNF_Tc (r:rs)
+listTc []     = returnTc []
+listTc (x:xs) = x			`thenTc` \ r ->
+		listTc xs		`thenTc` \ rs ->
+		returnTc (r:rs)
 
+mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
+mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [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)
-
+mapTc f []     = returnTc []
+mapTc f (x:xs) = f x		`thenTc` \ r ->
+		 mapTc f xs	`thenTc` \ rs ->
+		 returnTc (r:rs)
+mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
+
+
+foldrTc    :: (a -> b -> TcM b)    -> b -> [a] -> TcM b
+foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
+foldrTc k z []     = returnTc z
+foldrTc k z (x:xs) = foldrTc k z xs	`thenTc` \r ->
+		     k x r
+
+foldlTc    :: (a -> b -> TcM a)    -> a -> [b] -> TcM a
+foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
+foldlTc k z []     = returnTc z
+foldlTc k z (x:xs) = k z x		`thenTc` \r ->
+		     foldlTc k r xs
+
+mapAndUnzipTc    :: (a -> TcM (b,c))    -> [a]   -> TcM ([b],[c])
+mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a]   -> NF_TcM ([b],[c])
+mapAndUnzipTc f []     = returnTc ([],[])
+mapAndUnzipTc f (x:xs) = f x			`thenTc` \ (r1,r2) ->
+			 mapAndUnzipTc f xs	`thenTc` \ (rs1,rs2) ->
+			 returnTc (r1:rs1, r2:rs2)
+
+mapAndUnzip3Tc    :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
+mapAndUnzip3Tc f []     = returnTc ([],[],[])
+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 b)    -> Bag a -> TcM (Bag b)
+mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
+mapBagTc f bag
+  = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 -> 
+		        b2 `thenTc` \ r2 -> 
+		        returnTc (unionBags r1 r2))
+	    (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
+	    (returnTc emptyBag)
+	    bag
+
+fixTc    :: (a -> TcM a)    -> TcM a
 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixNF_Tc m sw_chkr dtys subst us errs src_loc
-  = lim
-  where
-    lim = m result sw_chkr dtys subst us errs src_loc
-    (result, _, _) = lim
+fixTc m env down = fixIO (\ loop -> m loop env down)
+{-# NOINLINE fixTc #-}
+-- aargh!  Not inlining fixTc alleviates a space leak problem.
+-- Normally fixTc is used with a lazy tuple match: if the optimiser is
+-- shown the definition of fixTc, it occasionally transforms the code
+-- in such a way that the code generator doesn't spot the selector
+-- thunks.  Sigh.
+
+recoverTc    :: TcM r -> TcM r -> TcM r
+recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM 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}
 
-@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}.  You use it
-when you are darn sure that the TcM won't actually fail!
+@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.
+
+So we compromise and use unsafeInterleaveIO.
+
+We throw away any error messages!
 
 \begin{code}
-noFailTc :: TcM a -> NF_TcM a
+forkNF_Tc :: NF_TcM r -> NF_TcM r
+forkNF_Tc m down@(TcDown { tc_us = u_var }) env
+  = 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) ;
+		let { down' = down { tc_us = us_var', tc_errs = err_var' } };
+		m down' env
+			-- ToDo: optionally dump any error messages
+		})
+\end{code}
 
-noFailTc expr sw_chkr dtys subst us errs src_loc
-  = case (expr sw_chkr dtys subst us errs src_loc) of
-      TcFailed _ _ -> panic "Failure in noFailTc!"
-      TcSucceeded result subst errs
-    	-> (result, subst, errs)
+\begin{code}
+traceTc :: SDoc -> NF_TcM ()
+traceTc doc (TcDown { tc_dflags=dflags }) env 
+  | dopt Opt_D_dump_tc_trace dflags = printDump doc
+  | otherwise			    = return ()
+
+ioToTc :: IO a -> NF_TcM a
+ioToTc io down env = io
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
+\subsection{Error handling}
 %*									*
 %************************************************************************
 
-These functions extract uniques from the monad. There are two unique
-supplies embedded in the monad.
-\begin{itemize}
-\item
-normal unique supply
-\item
-special unique supply for TyVars (these index the substitution)
-\end{itemize}
-
 \begin{code}
-getUniquesTc :: Int -> NF_TcM [Unique]
-getUniquesTc n sw_chkr dtys subst us errs src_loc
-  = case (getSUniques n us) of { uniques ->
-    (uniques, subst, errs) }
+getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+  = readIORef (getTcErrs down)
+
+failTc :: TcM a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = ioError (userError "Typecheck failed")
+
+failWithTc :: Message -> TcM a			-- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 
--- This simpler version is often adequate:
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc []	   = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)	`thenNF_Tc_` returnNF_Tc ()
 
-getUniqueTc :: NF_TcM Unique
-getUniqueTc sw_chkr dtys subst us errs src_loc
-  = case (getSUnique us) of { unique ->
-    (unique, subst, errs) }
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM a	-- Add an error message and fail
+failWithTcM env_and_msg
+  = addErrTcM env_and_msg	`thenNF_Tc_`
+    failTc
 
-rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
+checkTc :: Bool -> Message -> TcM ()		-- Check that the boolean is true
+checkTc True  err = returnTc ()
+checkTc False err = failWithTc err
 
-rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
-  = let
-	(rn_result, rn_errs)
-	  = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
-	    -- laziness may be good for you (see below)
-    in
-    ((rn_result, rn_errs), subst, errs)
+checkTcM :: Bool -> TcM () -> TcM ()	-- Check that the boolean is true
+checkTcM True  err = returnTc ()
+checkTcM False err = err
 
--- Special uniques for TyVars extracted from the substitution
+checkMaybeTc :: Maybe val -> Message -> TcM val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing    err = failWithTc err
 
-getTyVarUniquesTc :: Int -> NF_TcM [Unique]
-getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
+checkMaybeTcM :: Maybe val -> TcM val -> TcM val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing    err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM ()	-- 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
-    (subst2, uniques) = getSubstTyVarUniques n subst
+    ctxt     = getErrCtxt down
+    loc      = getLoc down
 
-getTyVarUniqueTc :: NF_TcM Unique
-getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM ()	-- 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 ()
+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 r)	-- Recovery action
+      -> TcM r				-- Thing to try
+      -> TcM 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
-    (subst2, unique) = getSubstTyVarUnique subst
+    errs_var = getTcErrs down
+
+    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
+		-- No errors, so return normally, but don't lose the warnings
+		if isEmptyBag m_warns then
+		   return result
+		else
+		   do (warns, errs) <- readIORef errs_var
+		      writeIORef errs_var (warns `unionBags` m_warns, errs)
+		      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 r -> TcM 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 r -> TcM r -> TcM 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 r -> Either_TcM r
+discardErrsTc main down env
+  = do new_errs_var <- newIORef (emptyBag,emptyBag)
+       main (setTcErrs down new_errs_var) env
 \end{code}
 
+
+
 %************************************************************************
 %*									*
-\subsection[TcM-extract]{Extractings other things from the monad}
+\subsection{Mutable variables}
 %*									*
 %************************************************************************
 
-These are functions which extract things from the monad.
+\begin{code}
+tcNewMutVar :: a -> NF_TcM (TcRef a)
+tcNewMutVar val down env = newIORef val
 
-Extending and applying the substitution.
+tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
+tcWriteMutVar var val down env = writeIORef var val
 
-ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
-a number of places where only the sequenced substitution is required.
-A lighter weight sequence substitution monad would be more appropriate
-with TcMonad interface functions defined here.
+tcReadMutVar :: TcRef a -> NF_TcM a
+tcReadMutVar var down env = readIORef var
 
-\begin{code}
-getTcSubst  	      ::	      NF_TcM Subst
-applyTcSubstToTy      :: TauType   -> NF_TcM TauType     
---UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType 
-applyTcSubstToTyVar   :: TyVar     -> NF_TcM TauType
-applyTcSubstToId      :: Id	   -> NF_TcM Id
-applyTcSubstToInst    :: Inst	   -> NF_TcM Inst
-
-getTcSubst sw_chkr dtys subst us errs src_loc
-  = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
-
-applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
-  = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
+tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
+tcNewMutTyVar name kind details down env = newMutTyVar name kind details
 
-{- UNUSED:
-applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
-  = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
-    returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
-    }
--}
+tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 
-applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
-  = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
+tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
+\end{code}
 
-applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
-  = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
-    returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
-    }
 
-applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
-  = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
-    returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
-    }
+%************************************************************************
+%*									*
+\subsection{The environment}
+%*									*
+%************************************************************************
 
-applyTcSubstToTyVars :: [TyVar]   -> NF_TcM [UniType]
-applyTcSubstToTys    :: [TauType] -> NF_TcM [TauType]
+\begin{code}
+tcGetEnv :: NF_TcM TcEnv
+tcGetEnv down env = return env
 
-applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
-applyTcSubstToTys    tys    = mapNF_Tc applyTcSubstToTy    tys
-applyTcSubstToInsts  insts  = mapNF_Tc applyTcSubstToInst  insts
+tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
+tcSetEnv new_env m down old_env = m down new_env
 \end{code}
 
-\begin{code}
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
-
-extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
-  = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
-    case extend_result of
-      SubstOK ->
-	TcSucceeded () new_subst errs
-
-      OccursCheck tyvar ty ->
-	TcFailed new_subst
-		 (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
-
-      AlreadyBound ty1 ->
-	    -- This should only happen in the case of a call to
-	    -- extendSubstTc from the unifier!  The way things are now
-	    -- we can't check for the AlreadyBound case in other calls
-	    -- to extendSubstTc, but we're confident it never shows up.
-	    -- Ugh!
-	unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
-    }
-\end{code}
 
+%************************************************************************
+%*									*
+\subsection{Source location}
+%*									*
+%************************************************************************
 
-@pruneSubstTc@ does nothing with an array substitution implementation!!!
 \begin{code}
-pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
-	     -> TcM a	-- Type-check this
-	     -> TcM a	-- Return same result but pruned subst
+tcGetDefaultTys :: NF_TcM [Type]
+tcGetDefaultTys down env = return (getDefaultTys down)
 
-pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
-  = m sw_chkr dtys subst uniqs errs src_loc
-\end{code}
+tcSetDefaultTys :: [Type] -> TcM r -> TcM r
+tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 
-\begin{code}
-getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
-\end{code}
+tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
+tcAddSrcLoc loc m down env = m (setLoc down loc) env
 
-\begin{code}
-getDefaultingTys :: NF_TcM [UniType]
-getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
+tcGetSrcLoc :: NF_TcM SrcLoc
+tcGetSrcLoc down env = return (getLoc down)
 
-setDefaultingTys :: [UniType] -> TcM a -> TcM a
-setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
-  = action sw_chkr dtys subst us errs src_loc
-\end{code}
+tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
+tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
+   = return (origin, loc, ctxt)
 
-\begin{code}
-addSrcLocTc :: SrcLoc -> TcM a -> TcM a
-addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
-  = expr sw_chkr dtys subst us errs new_locn
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
+			     -> TcM a -> TcM a
+tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
+tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
+
+tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM 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
 
-getSrcLocTc :: NF_TcM SrcLoc
-getSrcLocTc sw_chkr dtys subst us errs src_loc
-  = (src_loc, subst, errs)
+tcPopErrCtxt :: Either_TcM r -> Either_TcM  r
+tcPopErrCtxt m down env = m (popErrCtxt down) env
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection[TcM-check]{Error-detecting functions}
+\subsection{Unique supply}
 %*									*
 %************************************************************************
 
-The following TcM checks a Maybe type and fails with the given
-error message.
-
 \begin{code}
-checkMaybeTc :: Maybe val -> Error -> TcM val
-checkMaybeTc (Just result) err = returnTc result
-checkMaybeTc Nothing	   err = failTc	  err
-
-checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
-checkMaybesTc []	    err = returnTc []
-checkMaybesTc (Nothing:xs)  err = failTc   err
-checkMaybesTc ((Just v):xs) err
-  = checkMaybesTc xs err `thenTc` \ xs2 ->
-    returnTc (v:xs2)
-
-checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
-checkMaybeErrTc (Succeeded result) errfun = returnTc result
-checkMaybeErrTc (Failed err)	   errfun = failTc (errfun err)
-
-{- UNUSED:
-checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
-
-checkMaybeErrsTc []		    err_fun = returnTc []
-checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
-checkMaybeErrsTc ((Succeeded v):xs) err_fun
-  = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
-    returnTc (v:xs2)
--}
+tcGetUnique :: NF_TcM Unique
+tcGetUnique down env
+  = 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 :: NF_TcM [Unique]
+tcGetUniques down env
+  = do	uniq_supply <- readIORef u_var
+	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+	    uniqs		      = uniqsFromSupply uniq_s
+	writeIORef u_var new_uniq_supply
+	return uniqs
+  where
+    u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM 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}
 
+
+
 %************************************************************************
 %*									*
-\subsection[TcM-Insts]{Looking up instances}
+\subsection{TcDown}
 %*									*
 %************************************************************************
 
 \begin{code}
-lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
+data TcDown
+   = TcDown {
+        tc_dflags :: DynFlags,
+	tc_def    :: [Type],			-- Types used for defaulting
+	tc_us     :: (TcRef UniqSupply),	-- Unique supply
+	tc_loc    :: SrcLoc,			-- Source location
+	tc_ctxt   :: ErrCtxt,			-- Error context
+	tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
+   }
+
+type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]	
+			-- Innermost first.  Monadic so that we have a chance
+			-- to deal with bound type variables just before error
+			-- message construction
+\end{code}
 
-lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
-  = case (lookupInst uniqs inst) of
-      Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
+-- These selectors are *local* to TcMonad.lhs
 
-      Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
+\begin{code}
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
 
-lookupNoBindInst_Tc :: Inst -> TcM [Inst]
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
 
-lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
-  = case (lookupNoBindInst uniqs inst) of
-      Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
+getLoc (TcDown{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
 
-      Just insts -> TcSucceeded insts subst errs
-\end{code}
+getUniqSupplyVar (TcDown{tc_us=us}) = us
 
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+setErrCtxt down msg = down{tc_ctxt=[msg]}
+addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 
+popErrCtxt down = case tc_ctxt down of
+			[]     -> down
+			m : ms -> down{tc_ctxt = ms}
 
+doptsTc :: DynFlag -> NF_TcM Bool
+doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
+   = return (dopt dflag dflags)
+
+getDOptsTc :: NF_TcM DynFlags
+getDOptsTc (TcDown{tc_dflags=dflags}) env_down
+   = return dflags
+\end{code}
 
 
 
 
 %************************************************************************
 %*									*
-\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
+\subsection{TypeChecking Errors}
 %*									*
 %************************************************************************
 
-The "baby" Tc monad doesn't pass around the substitution.
-That means you can't use it to type-check bindings, but you can use
-if for everything else (interfaces, type decls, first pass of class and
-instance decls etc).
+\begin{code}
+type TcError   = Message
+type TcWarning = Message
+
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+		 | otherwise	      = take 3 ctxt
+
+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}
 
-Less importantly, it doesn't pass around the list of default decls either.
 
 
-Type declarations
-~~~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%*									*
+%************************************************************************
 
-\begin{code}
-type Baby_TcM result
-	=  (GlobalSwitch -> Bool)
-	-> SplitUniqSupply
-	-> Bag Error			-- threaded
-	-> SrcLoc			-- only passed downwards
-	-> Baby_TcResult result
+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...
 
-data Baby_TcResult result
-  = BabyTcFailed    (Bag Error)
+It appears in TcMonad because there are a couple of error-message-generation
+functions that deal with it.
 
-  | BabyTcSucceeded result (Bag Error)
-\end{code}
+\begin{code}
+type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 
+data InstOrigin
+  = OccurrenceOf Id		-- Occurrence of an overloaded identifier
 
-Standard plumbing
-~~~~~~~~~~~~~~~~~
+  | IPOcc (IPName Name)		-- Occurrence of an implicit parameter
+  | IPBind (IPName Name)	-- Binding site of an implicit parameter
 
-\begin{code}
-thenB_Tc   :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
-returnB_Tc :: a -> Baby_TcM a
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenB_Tc #-}
-{-# INLINE returnB_Tc #-}
-#endif
-
-thenB_Tc a b sw us errs loc
-  = case (splitUniqSupply us) of { (s1, s2) ->
-    case (a sw s1 errs loc) of
-      BabyTcFailed errs2          -> BabyTcFailed errs2
-      BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
-    }
+  | RecordUpdOrigin
 
-returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
-failB_Tc   err    sw us errs loc = BabyTcFailed (errs `snocBag` err)
+  | DataDeclOrigin		-- Typechecking a data declaration
 
-recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
-  = BabyTcSucceeded result errs
-  where
-    result = case try_this sw us emptyBag loc of
-		BabyTcSucceeded result errs_from_branch -> result
-		BabyTcFailed errs_from_branch 	        -> return_on_failure
+  | InstanceDeclOrigin		-- Typechecking an instance decl
 
-fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
-fixB_Tc k sw us errs loc
-  = result
-  where
-    result = k val sw us errs loc
-    val = case result of
-	    BabyTcSucceeded val errs -> val
-	    BabyTcFailed errs	     -> panic "fixB_Tc failed"
-
-babyTcMtoTcM :: Baby_TcM a -> TcM a
-babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
-  = case m sw_chkr us errs src_loc of
-	BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
-	BabyTcFailed errs2	     -> TcFailed subst errs2
-
-babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
-babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
-  = case m sw_chkr us errs src_loc of
-	BabyTcSucceeded result errs2 -> (result, subst, errs2)
-	BabyTcFailed errs2	     -> panic "babyTcMtoNF_TcM"
-\end{code}
+  | LiteralOrigin HsOverLit	-- Occurrence of a literal
 
-\begin{code}
-uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
-
-uniqSMtoBabyTcM u_action sw us errs loc
-  = let
-	u_result = u_action us
-	-- at least one use *needs* this laziness
-    in
-    BabyTcSucceeded u_result errs
-\end{code}
+  | PatOrigin RenamedPat
 
-\begin{code}
-thenB_Tc_ m k = m `thenB_Tc` \ _ -> 
-		k
-
-mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
-mapB_Tc f []     = returnB_Tc []
-mapB_Tc f (x:xs) = f x		`thenB_Tc` \ fx -> 
-		   mapB_Tc f xs	`thenB_Tc` \ fxs -> 
-		   returnB_Tc (fx:fxs)
-\end{code}
+  | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+  | PArrSeqOrigin  RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
 
+  | SignatureOrigin		-- A dict created from a type signature
+  | Rank2Origin			-- A dict created when typechecking the argument
+				-- of a rank-2 typed function
 
-Primitives
-~~~~~~~~~~
+  | DoOrigin			-- The monad for a do expression
 
-\begin{code}
-getUniqueB_Tc  :: Baby_TcM Unique
-getUniquesB_Tc :: Int -> Baby_TcM [Unique]
+  | ClassDeclOrigin		-- Manufactured during a class decl
 
-getUniqueB_Tc sw us errs loc
-  = case (getSUnique us) of { unique ->
-    BabyTcSucceeded unique errs }
+  | InstanceSpecOrigin	Class	-- in a SPECIALIZE instance pragma
+			Type
 
-getUniquesB_Tc n sw us errs loc
-  = case (getSUniques n us) of { uniques ->
-    BabyTcSucceeded uniques errs }
+	-- 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].)
 
-addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
-addSrcLocB_Tc new_locn m sw us errs loc
-  = m sw us errs new_locn
+  | ValSpecOrigin	Name	-- in a SPECIALIZE pragma for a value
 
-getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
+	-- 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.
 
-getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
-\end{code}
+  | CCallOrigin		String			-- CCall label
+			(Maybe RenamedHsExpr)	-- Nothing if it's the result
+						-- Just arg, for an argument
 
+  | LitLitOrigin	String	-- the litlit
 
-Useful functions
-~~~~~~~~~~~~~~~~
+  | UnknownOrigin	-- Help! I give up...
+\end{code}
 
 \begin{code}
-checkB_Tc :: Bool -> Error -> Baby_TcM ()
-
-checkB_Tc True  err = failB_Tc err
-checkB_Tc False err = returnB_Tc ()
+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 (IPOcc name)
+      	= hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
+    pp_orig (IPBind name)
+      	= hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
+    pp_orig RecordUpdOrigin
+	= ptext SLIT("a record update")
+    pp_orig DataDeclOrigin
+	= ptext SLIT("the data type declaration")
+    pp_orig InstanceDeclOrigin
+	= ptext SLIT("the instance declaration")
+    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 (ArithSeqOrigin seq)
+	= hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+    pp_orig (PArrSeqOrigin seq)
+	= hsep [ptext SLIT("the parallel array 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}