merge GHC HEAD

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

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 097db04..c86b081 100644 (file)
--- 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
@@ -71,11 +72,10 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
         meta_var     <- newIORef initTyVarUnique ;
        tvs_var      <- newIORef emptyVarSet ;
-       dfuns_var    <- newIORef emptyNameSet ;
-       keep_var     <- newIORef emptyNameSet ;
+        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 ;
@@ -97,8 +97,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = emptyInstEnv,
                tcg_fam_inst_env  = emptyFamInstEnv,
-               tcg_inst_uses = dfuns_var,
-               tcg_th_used   = th_var,
+                tcg_th_used   = th_var,
                tcg_exports  = [],
                tcg_imports  = emptyImportAvails,
                 tcg_used_rdrnames = used_rdr_var,
@@ -115,11 +114,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                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_fam_insts = [],
+                tcg_rules     = [],
+                tcg_fords     = [],
+                tcg_vects     = [],
+                tcg_dfun_n    = dfun_n_var,
+                tcg_keep      = keep_var,
                tcg_doc_hdr   = Nothing,
                 tcg_hpc       = False,
                 tcg_main      = Nothing
@@ -135,7 +135,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
                 tcl_meta       = meta_var,
-               tcl_untch      = initTyVarUnique
+               tcl_untch      = initTyVarUnique,
+                tcl_hetMetLevel    = []
             } ;
        } ;
    
@@ -148,7 +149,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) ;
@@ -168,9 +169,8 @@ initTcPrintErrors   -- Used from the interactive loop only
        -> Module 
        -> TcM r
        -> IO (Messages, Maybe r)
-initTcPrintErrors env mod todo = do
-  (msgs, res) <- initTc env HsSrcFile False mod todo
-  return (msgs, res)
+
+initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
 \end{code}
 
 %************************************************************************
@@ -407,7 +407,6 @@ traceRn, traceSplice :: SDoc -> TcRn ()
 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 traceSplice  = traceOptTcRn Opt_D_dump_splices
 
-
 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
@@ -454,6 +453,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)) }
 
@@ -611,6 +613,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}
 
 
@@ -771,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
                           env { tcl_ctxt = upd ctxt })
 
--- Conditionally add an error context
-maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
-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 { [] -> []; (_ : ms) -> ms })
 
@@ -887,6 +892,9 @@ add_err_tcm tidy_env err_msg loc ctxt
 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 -- Tidy the error info, trimming excessive contexts
 mkErrInfo env ctxts
+ | opt_PprStyle_Debug     -- In -dppr-debug style the output 
+ = return empty                  -- just becomes too voluminous
+ | otherwise
  = go 0 env ctxts
  where
    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
@@ -956,17 +964,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 ;
@@ -1127,7 +1150,7 @@ failIfM :: Message -> IfL a
 failIfM msg
   = do         { env <- getLclEnv
        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-       ; liftIO (printErrs (full_msg defaultErrStyle))
+       ; liftIO (printErrs full_msg defaultErrStyle)
        ; failM }
 
 --------------------
@@ -1162,7 +1185,7 @@ forkM_maybe doc thing_inside
                    ; return Nothing }
        }}
   where
-    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+    print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
 
 forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside