Check whether the main function is actually exported (#414)
[ghc-hetmet.git] / compiler / typecheck / TcRnMonad.lhs
index 11e6bba..f4b9131 100644 (file)
@@ -3,13 +3,6 @@
 %
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module TcRnMonad(
        module TcRnMonad,
        module TcRnTypes,
@@ -30,7 +23,6 @@ import TcType
 import InstEnv
 import FamInstEnv
 
-import Coercion
 import Var
 import Id
 import VarSet
@@ -39,7 +31,6 @@ import ErrUtils
 import SrcLoc
 import NameEnv
 import NameSet
-import OccName
 import Bag
 import Outputable
 import UniqSupply
@@ -49,10 +40,11 @@ import DynFlags
 import StaticFlags
 import FastString
 import Panic
+import Util
+
 import System.IO
 import Data.IORef
-import Control.Exception
+import qualified Data.Set as Set
 import Control.Monad
 \end{code}
 
@@ -78,11 +70,14 @@ initTc :: HscEnv
 initTc hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
        tvs_var      <- newIORef emptyVarSet ;
-       type_env_var <- newIORef emptyNameEnv ;
        dfuns_var    <- newIORef emptyNameSet ;
        keep_var     <- newIORef emptyNameSet ;
+    used_rdrnames_var <- newIORef Set.empty ;
        th_var       <- newIORef False ;
-       dfun_n_var   <- newIORef 1 ;
+       dfun_n_var   <- newIORef emptyOccSet ;
+       type_env_var <- case hsc_type_env_var hsc_env of {
+                           Just (_mod, te_var) -> return te_var ;
+                           Nothing             -> newIORef emptyNameEnv } ;
        let {
             maybe_rn_syntax empty_val
                | keep_rn_syntax = Just empty_val
@@ -93,7 +88,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_src       = hsc_src,
                tcg_rdr_env   = hsc_global_rdr_env hsc_env,
                tcg_fix_env   = emptyNameEnv,
-               tcg_field_env = emptyNameEnv,
+               tcg_field_env = RecFields emptyNameEnv emptyNameSet,
                tcg_default   = Nothing,
                tcg_type_env  = hsc_global_type_env hsc_env,
                tcg_type_env_var = type_env_var,
@@ -103,34 +98,38 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_th_used   = th_var,
                tcg_exports  = [],
                tcg_imports  = emptyImportAvails,
+        tcg_used_rdrnames = used_rdrnames_var,
                tcg_dus      = emptyDUs,
 
-                tcg_rn_imports = maybe_rn_syntax [],
+                tcg_rn_imports = [],
                 tcg_rn_exports = maybe_rn_syntax [],
                tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
 
                tcg_binds    = emptyLHsBinds,
-               tcg_deprecs  = NoDeprecs,
+               tcg_warns    = NoWarnings,
+               tcg_anns     = [],
                tcg_insts    = [],
                tcg_fam_insts= [],
                tcg_rules    = [],
                tcg_fords    = [],
                tcg_dfun_n   = dfun_n_var,
                tcg_keep     = keep_var,
-               tcg_doc      = Nothing,
-               tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
-                tcg_hpc      = False
+               tcg_doc_hdr  = Nothing,
+                tcg_hpc      = False,
+                tcg_main     = Nothing
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
-               tcl_loc        = mkGeneralSrcSpan FSLIT("Top level"),
+               tcl_loc        = mkGeneralSrcSpan (fsLit "Top level"),
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
                tcl_arrow_ctxt = NoArrowCtxt,
                tcl_env        = emptyNameEnv,
                tcl_tyvars     = tvs_var,
-               tcl_lie        = panic "initTc:LIE"     -- LIE only valid inside a getLIE
+               tcl_lie        = panic "initTc:LIE", -- only valid inside getLIE
+               tcl_tybinds    = panic "initTc:tybinds" 
+                                               -- only valid inside a getTyBinds
             } ;
        } ;
    
@@ -155,11 +154,10 @@ initTcPrintErrors -- Used from the interactive loop only
        :: HscEnv
        -> Module 
        -> TcM r
-       -> IO (Maybe r)
+       -> IO (Messages, Maybe r)
 initTcPrintErrors env mod todo = do
   (msgs, res) <- initTc env HsSrcFile False mod todo
-  printErrorsAndWarnings (hsc_dflags env) msgs
-  return res
+  return (msgs, res)
 \end{code}
 
 %************************************************************************
@@ -259,29 +257,28 @@ getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 getEps :: TcRnIf gbl lcl ExternalPackageState
 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 
--- Updating the EPS.  This should be an atomic operation.
--- Note the delicate 'seq' which forces the EPS before putting it in the
--- variable.  Otherwise what happens is that we get
---     write eps_var (....(unsafeRead eps_var)....)
--- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
--- we make the unsafeRead happen before we update the variable.
-
+-- | Update the external package state.  Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
          -> TcRnIf gbl lcl a
-updateEps upd_fn = do  { traceIf (text "updating EPS")
-                       ; eps_var <- getEpsVar
-                       ; eps <- readMutVar eps_var
-                       ; let { (eps', val) = upd_fn eps }
-                       ; seq eps' (writeMutVar eps_var eps')
-                       ; return val }
+updateEps upd_fn = do
+  traceIf (text "updating EPS")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var upd_fn
 
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
           -> TcRnIf gbl lcl ()
-updateEps_ upd_fn = do { traceIf (text "updating EPS_")
-                       ; eps_var <- getEpsVar
-                       ; eps <- readMutVar eps_var
-                       ; let { eps' = upd_fn eps }
-                       ; seq eps' (writeMutVar eps_var eps') }
+updateEps_ upd_fn = do
+  traceIf (text "updating EPS_")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 
 getHpt :: TcRnIf gbl lcl HomePackageTable
 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
@@ -331,6 +328,10 @@ newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 newSysLocalIds fs tys
   = do { us <- newUniqueSupply
        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
+
+instance MonadUnique (IOEnv (Env gbl lcl)) where
+        getUniqueM = newUnique
+        getUniqueSupplyM = newUniqueSupply
 \end{code}
 
 
@@ -341,13 +342,13 @@ newSysLocalIds fs tys
 %************************************************************************
 
 \begin{code}
-traceTc, traceRn :: SDoc -> TcRn ()
+traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 traceTc      = traceOptTcRn Opt_D_dump_tc_trace
 traceSplice  = traceOptTcRn Opt_D_dump_splices
 
 
-traceIf :: SDoc -> TcRnIf m n ()       
+traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 
@@ -361,14 +362,18 @@ traceOptTcRn flag doc = ifOptM flag $ do
                        { ctxt <- getErrCtxt
                        ; loc  <- getSrcSpanM
                        ; env0 <- tcInitTidyEnv
-                       ; ctxt_msgs <- do_ctxt env0 ctxt 
-                       ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+                       ; err_info <- mkErrInfo env0 ctxt 
+                       ; let real_doc = mkLocMessage loc (doc $$ err_info)
                        ; dumpTcRn real_doc }
 
 dumpTcRn :: SDoc -> TcRn ()
-dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
-                    dflags <- getDOpts ;
-                   liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
+dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv 
+                  ; dflags <- getDOpts 
+                  ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
+
+debugDumpTcRn :: SDoc -> TcRn ()
+debugDumpTcRn doc | opt_NoDebugOutput = return ()
+                  | otherwise         = dumpTcRn doc
 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
@@ -411,11 +416,6 @@ extendFixityEnv new_bit
 getRecFieldEnv :: TcRn RecFieldEnv
 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 
-extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a
-extendRecFieldEnv new_bit
-  = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> 
-               env {tcg_field_env = old_env `plusNameEnv` new_bit})         
-
 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 \end{code}
@@ -455,6 +455,7 @@ wrapLocSndM fn (L loc a) =
     return (b, L loc c)
 \end{code}
 
+Reporting errors
 
 \begin{code}
 getErrsVar :: TcRn (TcRef Messages)
@@ -463,50 +464,31 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
-addErr :: Message -> TcRn ()
+addErr :: Message -> TcRn ()   -- Ignores the context stack
 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 
-addLocErr :: Located e -> (e -> Message) -> TcRn ()
-addLocErr (L loc e) fn = addErrAt loc (fn e)
+failWith :: Message -> TcRn a
+failWith msg = addErr msg >> failM
 
 addErrAt :: SrcSpan -> Message -> TcRn ()
-addErrAt loc msg = addLongErrAt loc msg empty
-
-addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
-addLongErrAt loc msg extra
-  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
-        errs_var <- getErrsVar ;
-        rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-        let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
-        (warns, errs) <- readMutVar errs_var ;
-        writeMutVar errs_var (warns, errs `snocBag` err) }
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt 
+                     ; tidy_env <- tcInitTidyEnv
+                      ; err_info <- mkErrInfo tidy_env ctxt
+                     ; addLongErrAt loc msg err_info }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 addErrs msgs = mapM_ add msgs
             where
               add (loc,msg) = addErrAt loc msg
 
-addReport :: Message -> TcRn ()
-addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
-
-addReportAt :: SrcSpan -> Message -> TcRn ()
-addReportAt loc msg
-  = do { errs_var <- getErrsVar ;
-        rdr_env <- getGlobalRdrEnv ;
-         dflags <- getDOpts ;
-        let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
-        (warns, errs) <- readMutVar errs_var ;
-        writeMutVar errs_var (warns `snocBag` warn, errs) }
-
 addWarn :: Message -> TcRn ()
-addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
+addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
 
 addWarnAt :: SrcSpan -> Message -> TcRn ()
-addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg)
-
-addLocWarn :: Located e -> (e -> Message) -> TcRn ()
-addLocWarn (L loc e) fn = addReportAt loc (fn e)
+addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 
 checkErr :: Bool -> Message -> TcRn ()
 -- Add the error if the bool is False
@@ -514,7 +496,7 @@ checkErr ok msg = unless ok (addErr msg)
 
 warnIf :: Bool -> Message -> TcRn ()
 warnIf True  msg = addWarn msg
-warnIf False msg = return ()
+warnIf False _   = return ()
 
 addMessages :: Messages -> TcRn ()
 addMessages (m_warns, m_errs)
@@ -539,14 +521,46 @@ discardWarnings thing_inside
 \end{code}
 
 
+%************************************************************************
+%*                                                                     *
+       Shared error message stuff: renamer and typechecker
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+addReport :: Message -> Message -> TcRn ()
+addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
+
+addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
+addReportAt loc msg extra_info
+  = do { errs_var <- getErrsVar ;
+        rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+        let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+                                   msg extra_info } ;
+        (warns, errs) <- readMutVar errs_var ;
+        writeMutVar errs_var (warns `snocBag` warn, errs) }
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
+  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;        
+        errs_var <- getErrsVar ;
+        rdr_env <- getGlobalRdrEnv ;
+         dflags <- getDOpts ;
+        let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
+        (warns, errs) <- readMutVar errs_var ;
+        writeMutVar errs_var (warns, errs `snocBag` err) }
+\end{code}
+
+
 \begin{code}
-try_m :: TcRn r -> TcRn (Either Exception r)
+try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 -- Does try_m, with a debug-trace on failure
 try_m thing 
   = do { mb_r <- tryM thing ;
         case mb_r of 
             Left exn -> do { traceTc (exn_msg exn); return mb_r }
-            Right r  -> return mb_r }
+            Right _  -> return mb_r }
   where
     exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
 
@@ -558,7 +572,7 @@ recoverM :: TcRn r  -- Recovery action; do this if the main one fails
 recoverM recover thing 
   = do { mb_res <- try_m thing ;
         case mb_res of
-          Left exn  -> recover
+          Left _    -> recover
           Right res -> return res }
 
 
@@ -566,8 +580,8 @@ recoverM recover thing
 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 -- Drop elements of the input that fail, so the result
 -- list can be shorter than the argument list
-mapAndRecoverM f []     = return []
-mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x)
+mapAndRecoverM _ []     = return []
+mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
                             ; rs <- mapAndRecoverM f xs
                             ; return (case mb_r of
                                          Left _  -> rs
@@ -586,7 +600,7 @@ tryTc m
        res  <- try_m (setErrsVar errs_var m) ; 
        msgs <- readMutVar errs_var ;
        return (msgs, case res of
-                           Left exn  -> Nothing
+                           Left _  -> Nothing
                            Right val -> Just val)
        -- The exception is always the IOEnv built-in
        -- in exception; see IOEnv.failM
@@ -646,7 +660,7 @@ checkNoErrs main
   = do { (msgs, mb_res) <- tryTcLIE main
        ; addMessages msgs
        ; case mb_res of
-           Nothing   -> failM
+           Nothing  -> failM
            Just val -> return val
        } 
 
@@ -671,26 +685,28 @@ failIfErrsM = ifErrsM failM (return ())
 
 %************************************************************************
 %*                                                                     *
-       Context management and error message generation
-                   for the type checker
+       Context management for the type checker
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-getErrCtxt :: TcM ErrCtxt
+getErrCtxt :: TcM [ErrCtxt]
 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 
-setErrCtxt :: ErrCtxt -> TcM a -> TcM a
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 
 addErrCtxt :: Message -> TcM a -> TcM a
 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 
 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+addLandmarkErrCtxt :: Message -> TcM a -> TcM a
+addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
 
 -- Helper function for the above
-updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
                           env { tcl_ctxt = upd ctxt })
 
@@ -700,20 +716,26 @@ maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
 maybeAddErrCtxt Nothing    thing_inside = thing_inside
 
 popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 
 getInstLoc :: InstOrigin -> TcM InstLoc
 getInstLoc origin
   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
         return (InstLoc origin loc (tcl_ctxt env)) }
 
-addInstCtxt :: InstLoc -> TcM a -> TcM a
+setInstCtxt :: InstLoc -> TcM a -> TcM a
 -- Add the SrcSpan and context from the first Inst in the list
 --     (they all have similar locations)
-addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
-  = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
+setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
+  = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+            Error message generation (type checker)
+%*                                                                     *
+%************************************************************************
+
     The addErrTc functions add an error message, but do not cause failure.
     The 'M' variants pass a TidyEnv that has already been used to
     tidy up the message; we then use it to tidy the context messages
@@ -745,7 +767,7 @@ failWithTcM local_and_msg
   = addErrTcM local_and_msg >> failM
 
 checkTc :: Bool -> Message -> TcM ()        -- Check that the boolean is true
-checkTc True  err = return ()
+checkTc True  _   = return ()
 checkTc False err = failWithTc err
 \end{code}
 
@@ -759,8 +781,8 @@ addWarnTc msg = do { env0 <- tcInitTidyEnv
 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 addWarnTcM (env0, msg)
  = do { ctxt <- getErrCtxt ;
-       ctxt_msgs <- do_ctxt env0 ctxt ;
-       addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
+       err_info <- mkErrInfo env0 ctxt ;
+       addReport (ptext (sLit "Warning:") <+> msg) err_info }
 
 warnTc :: Bool -> Message -> TcM ()
 warnTc warn_if_true warn_msg
@@ -796,45 +818,58 @@ tcInitTidyEnv
        Other helper functions
 
 \begin{code}
+add_err_tcm :: TidyEnv -> Message -> SrcSpan
+            -> [ErrCtxt]
+            -> TcM ()
 add_err_tcm tidy_env err_msg loc ctxt
- = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-       addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
-
-do_ctxt tidy_env []
- = return []
-do_ctxt tidy_env (c:cs)
- = do {        (tidy_env', m) <- c tidy_env  ;
-       ms             <- do_ctxt tidy_env' cs  ;
-       return (m:ms) }
-
-ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
-                | otherwise          = take 3 ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+       addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+ = go 0 env ctxts
+ where
+   go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+   go _ _   [] = return empty
+   go n env ((is_landmark, ctxt) : ctxts)
+     | is_landmark || opt_PprStyle_Debug || n < mAX_CONTEXTS
+     = do { (env', msg) <- ctxt env
+         ; let n' = if is_landmark then n else n+1
+          ; rest <- go n' env' ctxts
+         ; return (msg $$ rest) }
+     | otherwise
+     = go n env ctxts
+
+mAX_CONTEXTS :: Int    -- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
 \end{code}
 
 debugTc is useful for monadic debugging code
 
 \begin{code}
 debugTc :: TcM () -> TcM ()
-#ifdef DEBUG
-debugTc thing = thing
-#else
-debugTc thing = return ()
-#endif
+debugTc thing
+ | debugIsOn = thing
+ | otherwise = return ()
 \end{code}
 
- %************************************************************************
+%************************************************************************
 %*                                                                     *
             Type constraints (the so-called LIE)
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-nextDFunIndex :: TcM Int       -- Get the next dfun index
-nextDFunIndex = do { env <- getGblEnv
-                  ; let dfun_n_var = tcg_dfun_n env
-                  ; n <- readMutVar dfun_n_var
-                  ; writeMutVar dfun_n_var (n+1)
-                  ; return n }
+chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
+chooseUniqueOccTc fn =
+  do { env <- getGblEnv
+     ; let dfun_n_var = tcg_dfun_n env
+     ; set <- readMutVar dfun_n_var
+     ; let occ = fn set
+     ; writeMutVar dfun_n_var (extendOccSet set occ)
+     ; return occ
+     }
 
 getLIEVar :: TcM (TcRef LIE)
 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
@@ -880,6 +915,44 @@ setLclTypeEnv lcl_env thing_inside
 
 %************************************************************************
 %*                                                                     *
+            Meta type variable bindings
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
+getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }
+
+getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
+getTcTyVarBinds thing_inside
+  = do { tybinds_var <- newMutVar emptyBag
+       ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var }) 
+                         thing_inside
+       ; tybinds <- readMutVar tybinds_var
+       ; return (res, tybinds) 
+       }
+
+bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
+bindMetaTyVar tv ty
+  = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
+                      ; return (isFlexi details) }, ppr tv )
+       ; tybinds_var <- getTcTyVarBindsVar
+       ; tybinds <- readMutVar tybinds_var
+       ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty) 
+       }
+
+getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
+getTcTyVarBindsRelation
+  = do { tybinds_var <- getTcTyVarBindsVar
+       ; tybinds <- readMutVar tybinds_var
+       ; return $ map freeTvs (bagToList tybinds)
+       }
+  where
+    freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
+\end{code}
+
+%************************************************************************
+%*                                                                     *
             Template Haskell context
 %*                                                                     *
 %************************************************************************
@@ -946,7 +1019,7 @@ initIfaceExtCore :: IfL a -> TcRn a
 initIfaceExtCore thing_inside
   = do  { tcg_env <- getGblEnv 
        ; let { mod = tcg_mod tcg_env
-             ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
+             ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
              ; if_env = IfGblEnv { 
                        if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
              ; if_lenv = mkIfLclEnv mod doc
@@ -957,9 +1030,11 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a
 -- Used when checking the up-to-date-ness of the old Iface
 -- Initialise the environment with no useful info at all
 initIfaceCheck hsc_env do_this
- = do  { let gbl_env = IfGblEnv { if_rec_types = Nothing }
-       ; initTcRnIf 'i' hsc_env gbl_env () do_this
-    }
+ = do let rec_types = case hsc_type_env_var hsc_env of
+                         Just (mod,var) -> Just (mod, readMutVar var)
+                         Nothing        -> Nothing
+          gbl_env = IfGblEnv { if_rec_types = rec_types }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
 
 initIfaceTc :: ModIface 
            -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
@@ -974,7 +1049,7 @@ initIfaceTc iface do_this
     }
   where
     mod = mi_module iface
-    doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
+    doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
 
 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
 -- Used when sucking in new Rules in SimplCore