[project @ 2000-11-10 15:12:50 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMonad.lhs

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index d71810c..c50e6fe 100644 (file)
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -21,13 +21,14 @@ module TcMonad(
        listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
 
        checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, 
-       failTc, failWithTc, addErrTc, addErrsTc, 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, tcGetDFunUniq,
-       doptsTc,
+       doptsTc, getDOptsTc,
 
        tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
        tcAddErrCtxtM, tcSetErrCtxtM,
@@ -50,7 +51,6 @@ import RnHsSyn                ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverL
 import Type            ( Type, Kind, PredType, ThetaType, RhoType, TauType,
                        )
 import ErrUtils                ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts      ( DynFlags, opt_PprStyle_Debug )
 
 import Bag             ( Bag, emptyBag, isEmptyBag,
                          foldBag, unitBag, unionBags, snocBag )
@@ -59,15 +59,15 @@ import Name         ( Name )
 import Var             ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
 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, lookupFM, addToFM, emptyFM )
-import UniqFM          ( UniqFM, emptyUFM )
+import UniqFM          ( emptyUFM )
 import Unique          ( Unique )
-import BasicTypes      ( Unused )
+import CmdLineOpts
 import Outputable
-import FastString      ( FastString )
 
 import IOExts          ( IORef, newIORef, readIORef, writeIORef,
                          unsafeInterleaveIO, fixIO
@@ -111,9 +111,6 @@ type TcKind      = TcType
 \begin{code}
 type NF_TcM r =  TcDown -> TcEnv -> IO r       -- Can't raise UserError
 type TcM    r =  TcDown -> TcEnv -> IO r       -- Can raise UserError
-       -- ToDo: nuke the 's' part
-       -- The difference between the two is
-       -- now for documentation purposes only
 
 type Either_TcM r =  TcDown -> TcEnv -> IO r   -- Either NF_TcM or TcM
        -- Used only in this file for type signatures which
@@ -124,24 +121,13 @@ type TcRef a = IORef a
 \end{code}
 
 \begin{code}
-<<<<<<< TcMonad.lhs
--- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
-
-initTc :: DynFlags
-       -> UniqSupply
-       -> (TcRef (UniqFM a) -> TcEnv)
-=======
-initTc :: TcEnv
-       -> SrcLoc
->>>>>>> 1.44
+
+initTc :: DynFlags 
+       -> TcEnv
        -> TcM r
-       -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
+       -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
 
-<<<<<<< TcMonad.lhs
-initTc dflags us initenv do_this
-=======
-initTc tc_env src_loc do_this
->>>>>>> 1.44
+initTc dflags tc_env do_this
   = do {
       us       <- mkSplitUniqSupply 'a' ;
       us_var   <- newIORef us ;
@@ -150,17 +136,12 @@ initTc tc_env src_loc do_this
       tvs_var  <- newIORef emptyUFM ;
 
       let
-<<<<<<< TcMonad.lhs
           init_down = TcDown dflags [] us_var dfun_var
                             noSrcLoc
-=======
-          init_down = TcDown [] us_var dfun_var
-                            src_loc
->>>>>>> 1.44
                             [] errs_var
       ;
 
-      maybe_res <- catch (do {  res <- do_this init_down env ;
+      maybe_res <- catch (do {  res <- do_this init_down tc_env ;
                                return (Just res)})
                         (\_ -> return Nothing) ;
         
@@ -289,7 +270,7 @@ forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
 
 \begin{code}
 traceTc :: SDoc -> NF_TcM ()
-traceTc doc down env = printErrs doc
+traceTc doc down env = printDump doc
 
 ioToTc :: IO a -> NF_TcM a
 ioToTc io down env = io
@@ -321,7 +302,7 @@ 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 ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
 
 -- The 'M' variants do the TidyEnv bit
 failWithTcM :: (TidyEnv, Message) -> TcM a     -- Add an error message and fail
@@ -652,9 +633,13 @@ getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 setErrCtxt down msg = down{tc_ctxt=[msg]}
 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 
-doptsTc :: (DynFlags -> Bool) -> TcM Bool
-doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
-   = return (dopt dflags)
+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}