X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=37e11663885c4829e4dd6085859a24ca61b4865f;hb=1add108e019be6bbdb340eea3900f7193d5daa6b;hp=92fa190642d30e3b884a1cdcc53b50e55700b2fa;hpb=61f93d4611724685c5808bcfd41e3d3e0f3aa94f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 92fa190..37e1166 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -22,6 +22,7 @@ import Name
 import TcType
 import InstEnv
 import FamInstEnv
+import PrelNames        ( iNTERACTIVE )
 
 import Var
 import Id
@@ -74,7 +75,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
         keep_var     <- newIORef emptyNameSet ;
         used_rdr_var <- newIORef Set.empty ;
 	th_var	     <- newIORef False ;
-	lie_var	     <- newIORef emptyBag ;
+        lie_var      <- newIORef emptyWC ;
 	dfun_n_var   <- newIORef emptyOccSet ;
 	type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
@@ -146,7 +147,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 
         -- Check for unsolved constraints
 	lie <- readIORef lie_var ;
-        if isEmptyBag lie 
+        if isEmptyWC lie
            then return ()
            else pprPanic "initTc: unsolved constraints" 
                          (pprWantedsWithLocs lie) ;
@@ -451,6 +452,9 @@ getModule = do { env <- getGblEnv; return (tcg_mod env) }
 setModule :: Module -> TcRn a -> TcRn a
 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
 
+getIsGHCi :: TcRn Bool
+getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
+
 tcIsHsBoot :: TcRn Bool
 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 
@@ -608,6 +612,14 @@ addLongErrAt loc msg extra
 	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
 	 (warns, errs) <- readTcRef errs_var ;
   	 writeTcRef errs_var (warns, errs `snocBag` err) }
+
+dumpDerivingInfo :: SDoc -> TcM ()
+dumpDerivingInfo doc
+  = do { dflags <- getDOpts
+       ; when (dopt Opt_D_dump_deriv dflags) $ do
+       { rdr_env <- getGlobalRdrEnv
+       ; let unqual = mkPrintUnqualified dflags rdr_env
+       ; liftIO (putMsgWith dflags unqual doc) } }
 \end{code}
 
 
@@ -953,17 +965,32 @@ setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 emitConstraints :: WantedConstraints -> TcM ()
 emitConstraints ct
   = do { lie_var <- getConstraintVar ;
-	 updTcRef lie_var (`andWanteds` ct) }
+         updTcRef lie_var (`andWC` ct) }
+
+emitFlat :: WantedEvVar -> TcM ()
+emitFlat ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addFlats` unitBag ct) }
+
+emitFlats :: Bag WantedEvVar -> TcM ()
+emitFlats ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addFlats` ct) }
+
+emitImplication :: Implication -> TcM ()
+emitImplication ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addImplics` unitBag ct) }
 
-emitConstraint :: WantedConstraint -> TcM ()
-emitConstraint ct
+emitImplications :: Bag Implication -> TcM ()
+emitImplications ct
   = do { lie_var <- getConstraintVar ;
-	 updTcRef lie_var (`extendWanteds` ct) }
+         updTcRef lie_var (`addImplics` ct) }
 
 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 -- (captureConstraints m) runs m, and returns the type constraints it generates
 captureConstraints thing_inside
-  = do { lie_var <- newTcRef emptyWanteds ;
+  = do { lie_var <- newTcRef emptyWC ;
 	 res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
 			  thing_inside ;
 	 lie <- readTcRef lie_var ;