X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=3e3322e85fa50c4d72f79365c2c427ba4aec581b;hb=4e342297f796001e7107d8c348bb023168954bc7;hp=2deadb007390cbb30c913574af03f00bcbc8a644;hpb=6e5c95e9102581703b8cb2734b87d7958bce4183;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 2deadb0..3e3322e 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,14 +1,14 @@
 \begin{code}
 module TcMonad(
 	TcType, 
-	TcTauType, TcThetaType, TcRhoType,
-	TcTyVar, TcTyVarSet,
+	TcTauType, TcPredType, TcThetaType, TcRhoType,
+	TcTyVar, TcTyVarSet, TcClassContext,
 	TcKind,
 
 	TcM, NF_TcM, TcDown, TcEnv, 
 
 	initTc,
-	returnTc, thenTc, thenTc_, mapTc, listTc,
+	returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
 	foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
 	mapBagTc, fixTc, tryTc, tryTc_, getErrsTc, 
 	traceTc, ioToTc,
@@ -21,12 +21,14 @@ module TcMonad(
 	listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
 	checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
-	failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+	failTc, failWithTc, addErrTc, addErrsTc, warnTc, 
+	recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
 	addErrTcM, addInstErrTcM, failWithTcM,
 
 	tcGetEnv, tcSetEnv,
 	tcGetDefaultTys, tcSetDefaultTys,
-	tcGetUnique, tcGetUniques,
+	tcGetUnique, tcGetUniques, 
+	doptsTc, getDOptsTc,
 
 	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
@@ -45,30 +47,26 @@ module TcMonad(
 
 import {-# SOURCE #-} TcEnv  ( TcEnv )
 
-import HsSyn		( HsLit )
-import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type		( Type, Kind, ThetaType, RhoType, TauType,
+import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
+import Type		( Type, Kind, PredType, ThetaType, RhoType, TauType,
 			)
-import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
-import CmdLineOpts      ( opt_PprStyle_Debug )
+import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
-import Class		( Class )
+import Class		( Class, ClassContext )
 import Name		( Name )
 import Var		( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
-import VarEnv		( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
+import VarEnv		( TidyEnv, emptyTidyEnv )
 import VarSet		( TyVarSet )
-import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply, 
+			  splitUniqSupply, mkSplitUniqSupply,
 			  UniqSM, initUs_ )
 import SrcLoc		( SrcLoc, noSrcLoc )
-import FiniteMap	( FiniteMap, emptyFM )
-import UniqFM		( UniqFM, emptyUFM )
+import UniqFM		( emptyUFM )
 import Unique		( Unique )
-import BasicTypes	( Unused )
-import Util
+import CmdLineOpts
 import Outputable
-import FastString	( FastString )
 
 import IOExts		( IORef, newIORef, readIORef, writeIORef,
 			  unsafeInterleaveIO, fixIO
@@ -79,8 +77,12 @@ infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
 \end{code}
 
 
-Types
-~~~~~
+%************************************************************************
+%*									*
+\subsection{Types}
+%*									*
+%************************************************************************
+
 \begin{code}
 type TcTyVar    = TyVar		-- Might be a mutable tyvar
 type TcTyVarSet = TyVarSet
@@ -91,24 +93,26 @@ type TcType = Type 		-- A TcType can have mutable type variables
 	-- a cannot occur inside a MutTyVar in T; that is,
 	-- T is "flattened" before quantifying over a
 
-type TcThetaType = ThetaType
-type TcRhoType   = RhoType
-type TcTauType   = TauType
-type TcKind      = TcType
+type TcClassContext = ClassContext
+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}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{The main monads: TcM, NF_TcM}
+%*									*
+%************************************************************************
 
 \begin{code}
-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 NF_TcM r =  TcDown -> TcEnv -> IO r	-- Can't raise UserError
+type TcM    r =  TcDown -> TcEnv -> IO r	-- Can raise UserError
 
-type Either_TcM s r =  TcDown -> TcEnv -> IO r	-- Either NF_TcM or TcM
+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
@@ -117,89 +121,91 @@ type TcRef a = IORef a
 \end{code}
 
 \begin{code}
--- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
 
-initTc :: UniqSupply
-       -> (TcRef (UniqFM a) -> TcEnv)
-       -> TcM s r
-       -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
+initTc :: DynFlags 
+       -> TcEnv
+       -> TcM r
+       -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
 
-initTc us initenv do_this
+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 [] us_var
-			     noSrcLoc
-			     [] errs_var
-	  init_env  = initenv tvs_var
+          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 init_env ;
+      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)
+      return (maybe_res, (warns, errs))
     }
 
 -- Monadic operations
 
-returnNF_Tc :: a -> NF_TcM s a
-returnTc    :: a -> TcM s a
+returnNF_Tc :: a -> NF_TcM a
+returnTc    :: a -> TcM a
 returnTc v down env = return v
 
-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    :: 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 s a    -> TcM s b        -> TcM s b
-thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
+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 s a]    -> TcM s [a]
-listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
+listTc    :: [TcM a]    -> TcM [a]
+listNF_Tc :: [NF_TcM a] -> NF_TcM [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]
-mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
+mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
+mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
+mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 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 s b)    -> b -> [a] -> TcM s b
-foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
+
+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 s a)    -> a -> [b] -> TcM s a
-foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
+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 s (b,c))    -> [a]   -> TcM s ([b],[c])
-mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
+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 s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
+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 s b)    -> Bag a -> TcM s (Bag b)
-mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
+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 -> 
@@ -208,12 +214,12 @@ mapBagTc f bag
 	    (returnTc emptyBag)
 	    bag
 
-fixTc    :: (a -> TcM s a)    -> TcM s a
-fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
+fixTc    :: (a -> TcM a)    -> TcM a
+fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM 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    :: 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)
 
@@ -243,8 +249,8 @@ 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
+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
@@ -254,18 +260,17 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 	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' } ;
+		let { down' = down { tc_us = us_var', tc_errs = err_var' } };
 		m down' env
 			-- ToDo: optionally dump any error messages
 		})
 \end{code}
 
 \begin{code}
-traceTc :: SDoc -> NF_TcM s ()
-traceTc doc down env = printErrs doc
+traceTc :: SDoc -> NF_TcM ()
+traceTc doc down env = printDump doc
 
-ioToTc :: IO a -> NF_TcM s a
+ioToTc :: IO a -> NF_TcM a
 ioToTc io down env = io
 \end{code}
 
@@ -277,52 +282,56 @@ ioToTc io down env = io
 %************************************************************************
 
 \begin{code}
-getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
+getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
 getErrsTc down env
   = readIORef (getTcErrs down)
 
-failTc :: TcM s a
+failTc :: TcM 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 :: Message -> TcM a			-- Add an error message and fail
 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 
-addErrTc :: Message -> NF_TcM s ()
+addErrTc :: Message -> NF_TcM ()
 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc []	   = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)	`thenNF_Tc_` returnNF_Tc ()
+
 -- The 'M' variants do the TidyEnv bit
-failWithTcM :: (TidyEnv, Message) -> TcM s a	-- Add an error message and fail
+failWithTcM :: (TidyEnv, Message) -> TcM 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 :: Bool -> Message -> TcM ()		-- Check that the boolean is true
 checkTc True  err = returnTc ()
 checkTc False err = failWithTc err
 
-checkTcM :: Bool -> TcM s () -> TcM s ()	-- Check that the boolean is true
+checkTcM :: Bool -> TcM () -> TcM ()	-- Check that the boolean is true
 checkTcM True  err = returnTc ()
 checkTcM False err = err
 
-checkMaybeTc :: Maybe val -> Message -> TcM s val
+checkMaybeTc :: Maybe val -> Message -> TcM val
 checkMaybeTc (Just val) err = returnTc val
 checkMaybeTc Nothing    err = failWithTc err
 
-checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
+checkMaybeTcM :: Maybe val -> TcM val -> TcM 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 :: (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
     ctxt     = getErrCtxt down
     loc      = getLoc down
 
-addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s ()	-- Add an error message but don't fail
+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
@@ -347,7 +356,7 @@ do_ctxt tidy_env (c:cs) down env
 	return (m:ms)
 
 -- warnings don't have an 'M' variant
-warnTc :: Bool -> Message -> NF_TcM s ()
+warnTc :: Bool -> Message -> NF_TcM ()
 warnTc warn_if_true warn_msg down env
   | warn_if_true 
   = do
@@ -369,9 +378,9 @@ warnTc warn_if_true warn_msg down env
 --	(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 :: ((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)
@@ -400,7 +409,7 @@ tryTc recover main down env
 --	(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 :: TcM r -> TcM r
 checkNoErrsTc main
   = tryTc my_recover main
   where
@@ -416,90 +425,108 @@ checkNoErrsTc main
 -- (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_ :: 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 s r -> Either_TcM s r
+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}
 
-Mutable variables
-~~~~~~~~~~~~~~~~~
+
+
+%************************************************************************
+%*									*
+\subsection{Mutable variables}
+%*									*
+%************************************************************************
+
 \begin{code}
-tcNewMutVar :: a -> NF_TcM s (TcRef a)
+tcNewMutVar :: a -> NF_TcM (TcRef a)
 tcNewMutVar val down env = newIORef val
 
-tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
+tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
 tcWriteMutVar var val down env = writeIORef var val
 
-tcReadMutVar :: TcRef a -> NF_TcM s a
+tcReadMutVar :: TcRef a -> NF_TcM a
 tcReadMutVar var down env = readIORef var
 
-tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
 tcNewMutTyVar name kind down env = newMutTyVar name kind
 
-tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
 tcNewSigTyVar name kind down env = newSigTyVar name kind
 
-tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
+tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 
-tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 \end{code}
 
 
-Environment
-~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{The environment}
+%*									*
+%************************************************************************
+
 \begin{code}
-tcGetEnv :: NF_TcM s TcEnv
+tcGetEnv :: NF_TcM TcEnv
 tcGetEnv down env = return env
 
-tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
+tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 tcSetEnv new_env m down old_env = m down new_env
 \end{code}
 
 
-Source location
-~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{Source location}
+%*									*
+%************************************************************************
+
 \begin{code}
-tcGetDefaultTys :: NF_TcM s [Type]
+tcGetDefaultTys :: NF_TcM [Type]
 tcGetDefaultTys down env = return (getDefaultTys down)
 
-tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
+tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 
-tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
+tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 
-tcGetSrcLoc :: NF_TcM s SrcLoc
+tcGetSrcLoc :: NF_TcM SrcLoc
 tcGetSrcLoc down env = return (getLoc down)
 
-tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
+tcGetInstLoc :: InstOrigin -> NF_TcM 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, 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 s r -> Either_TcM s r
+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
 \end{code}
 
 
-Unique supply
-~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{Unique supply}
+%*									*
+%************************************************************************
+
 \begin{code}
-tcGetUnique :: NF_TcM s Unique
+tcGetUnique :: NF_TcM Unique
 tcGetUnique down env
   = do  uniq_supply <- readIORef u_var
     	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
@@ -509,7 +536,7 @@ tcGetUnique down env
   where
     u_var = getUniqSupplyVar down
 
-tcGetUniques :: Int -> NF_TcM s [Unique]
+tcGetUniques :: Int -> NF_TcM [Unique]
 tcGetUniques n down env
   = do	uniq_supply <- readIORef u_var
 	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
@@ -519,7 +546,7 @@ tcGetUniques n down env
   where
     u_var = getUniqSupplyVar down
 
-uniqSMToTcM :: UniqSM a -> NF_TcM s a
+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
@@ -530,22 +557,25 @@ uniqSMToTcM m down env
 \end{code}
 
 
-\section{TcDown}
-%~~~~~~~~~~~~~~~
+
+%************************************************************************
+%*									*
+\subsection{TcDown}
+%*									*
+%************************************************************************
 
 \begin{code}
 data TcDown
-  = TcDown
-	[Type]			-- Types used for defaulting
-
-	(TcRef UniqSupply)	-- Unique supply
-
-	SrcLoc			-- Source location
-	ErrCtxt			-- Error context
-	(TcRef (Bag WarnMsg, 
-		  Bag ErrMsg))
-
-type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]	
+   = 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
@@ -554,27 +584,38 @@ type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
 -- These selectors are *local* to TcMonad.lhs
 
 \begin{code}
-getTcErrs (TcDown def us loc ctxt errs)      = errs
-setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
+
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
 
-getDefaultTys (TcDown def us loc ctxt errs)     = def
-setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
+getLoc (TcDown{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
 
-getLoc (TcDown def us loc ctxt errs)     = loc
-setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
+getUniqSupplyVar (TcDown{tc_us=us}) = us
 
-getUniqSupplyVar (TcDown def us loc ctxt errs) = us
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+setErrCtxt down msg = down{tc_ctxt=[msg]}
+addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 
-setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
-addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
-getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
+doptsTc :: DynFlag -> TcM Bool
+doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
+   = return (dopt dflag dflags)
+
+getDOptsTc :: TcM DynFlags
+getDOptsTc (TcDown{tc_dflags=dflags}) env_down
+   = return dflags
 \end{code}
 
 
 
 
-TypeChecking Errors
-~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%*									*
+\subsection{TypeChecking Errors}
+%*									*
+%************************************************************************
 
 \begin{code}
 type TcError   = Message
@@ -618,13 +659,16 @@ type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 data InstOrigin
   = OccurrenceOf Id		-- Occurrence of an overloaded identifier
 
+  | IPOcc Name			-- Occurrence of an implicit parameter
+  | IPBind Name			-- Binding site of an implicit parameter
+
   | RecordUpdOrigin
 
   | DataDeclOrigin		-- Typechecking a data declaration
 
   | InstanceDeclOrigin		-- Typechecking an instance decl
 
-  | LiteralOrigin HsLit		-- Occurrence of a literal
+  | LiteralOrigin RenamedHsOverLit	-- Occurrence of a literal
 
   | PatOrigin RenamedPat
 
@@ -669,6 +713,10 @@ pprInstLoc (orig, locn, ctxt)
   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 (LiteralOrigin lit)
 	= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
     pp_orig (PatOrigin pat)