Remove redundant tcg_visible_orphan_mods, it is recorded in imp_orphs.
[ghc.git] / compiler / typecheck / TcRnMonad.hs
index b7038ec..3c69b95 100644 (file)
@@ -86,7 +86,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         used_rdr_var <- newIORef Set.empty ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
-        infer_var    <- newIORef True ;
+        infer_var    <- newIORef (True, emptyBag) ;
         lie_var      <- newIORef emptyWC ;
         dfun_n_var   <- newIORef emptyOccSet ;
         type_env_var <- case hsc_type_env_var hsc_env of {
@@ -120,17 +120,19 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_mod            = mod,
                 tcg_src            = hsc_src,
                 tcg_sig_of         = getSigOf dflags (moduleName mod),
+                tcg_mod_name       = Nothing,
                 tcg_impl_rdr_env   = Nothing,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
                 tcg_field_env      = RecFields emptyNameEnv emptyNameSet,
-                tcg_default        = Nothing,
+                tcg_default        = if modulePackageKey mod == primPackageKey
+                                     then Just []  -- See Note [Default types]
+                                     else Nothing,
                 tcg_type_env       = emptyNameEnv,
                 tcg_type_env_var   = type_env_var,
                 tcg_inst_env       = emptyInstEnv,
                 tcg_fam_inst_env   = emptyFamInstEnv,
                 tcg_ann_env        = emptyAnnEnv,
-                tcg_visible_orphan_mods = mkModuleSet [mod],
                 tcg_th_used        = th_var,
                 tcg_th_splice_used = th_splice_var,
                 tcg_exports        = [],
@@ -224,7 +226,17 @@ initTcForLookup hsc_env thing_inside
              Nothing -> throwIO $ mkSrcErr $ snd msgs
              Just x -> return x }
 
-{-
+{- Note [Default types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The Integer type is simply not available in package ghc-prim (it is
+declared in integer-gmp).  So we set the defaulting types to (Just
+[]), meaning there are no default types, rather then Nothing, which
+means "use the default default types of Integer, Double".
+
+If you don't do this, attempted defaulting in package ghc-prim causes
+an actual crash (attempting to look up the Integer type).
+
+
 ************************************************************************
 *                                                                      *
                 Initialisation
@@ -463,7 +475,7 @@ instance MonadUnique (IOEnv (Env gbl lcl)) where
 {-
 ************************************************************************
 *                                                                      *
-                Debugging
+                Accessing input/output
 *                                                                      *
 ************************************************************************
 -}
@@ -502,15 +514,12 @@ traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
 -- | Typechecker trace
 traceTcN :: Int -> SDoc -> TcRn ()
 traceTcN level doc
-    = do dflags <- getDynFlags
-         ; when (level <= traceLevel dflags) $
-           traceOptTcRn Opt_D_dump_tc_trace doc }
+    = do dflags <- getDynFlags
+         when (level <= traceLevel dflags && not opt_NoDebugOutput) $
+             traceOptTcRn Opt_D_dump_tc_trace doc
 
 traceRn :: SDoc -> TcRn ()
-traceRn doc = traceOptTcRn Opt_D_dump_rn_trace doc
-
-traceSplice :: SDoc -> TcRn ()
-traceSplice doc = traceOptTcRn Opt_D_dump_splices doc
+traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
 
 -- | Output a doc if the given 'DumpFlag' is set.
 --
@@ -554,7 +563,7 @@ printForUserTcRn :: SDoc -> TcRn ()
 printForUserTcRn doc
   = do { dflags <- getDynFlags
        ; printer <- getPrintUnqualified dflags
-       ; liftIO (printInfoForUser dflags printer doc) }
+       ; liftIO (printOutputForUser dflags printer doc) }
 
 -- | Typechecker debug
 debugDumpTcRn :: SDoc -> TcRn ()
@@ -681,6 +690,9 @@ addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
 failWith :: MsgDoc -> TcRn a
 failWith msg = addErr msg >> failM
 
+failAt :: SrcSpan -> MsgDoc -> TcRn a
+failAt loc msg = addErrAt loc msg >> failM
+
 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
 -- addErrAt is mainly (exclusively?) used by the renamer, where
 -- tidying is not an issue, but it's all lazy so the extra
@@ -765,7 +777,7 @@ reportWarning err
        ; writeTcRef errs_var (warns `snocBag` warn, errs) }
 
 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
--- Does try_m, with a debug-trace on failure
+-- Does tryM, with a debug-trace on failure
 try_m thing
   = do { mb_r <- tryM thing ;
          case mb_r of
@@ -1006,6 +1018,10 @@ checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
 checkTc True  _   = return ()
 checkTc False err = failWithTc err
 
+failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
+failIfTc False _   = return ()
+failIfTc True  err = failWithTc err
+
 --         Warnings have no 'M' variant, nor failure
 
 warnTc :: Bool -> MsgDoc -> TcM ()
@@ -1282,18 +1298,28 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 -}
 
 -- | Mark that safe inference has failed
-recordUnsafeInfer :: TcM ()
-recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
+-- See Note [Safe Haskell Overlapping Instances Implementation]
+-- although this is used for more than just that failure case.
+recordUnsafeInfer :: WarningMessages -> TcM ()
+recordUnsafeInfer warns =
+    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
 
 -- | Figure out the final correct safe haskell mode
 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
 finalSafeMode dflags tcg_env = do
-    safeInf <- readIORef (tcg_safeInfer tcg_env)
+    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
     return $ case safeHaskell dflags of
         Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
                 | otherwise                     -> Sf_None
         s -> s
 
+-- | Switch instances to safe instances if we're in Safe mode.
+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
+fixSafeInstances sfMode | sfMode /= Sf_Safe = id
+fixSafeInstances _ = map fixSafe
+  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
+                       in inst { is_flag = new_flag }
+
 {-
 ************************************************************************
 *                                                                      *