[commit: ghc] master: Implement lookupGlobal in TcEnv, and use it (816d48a)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/816d48a9b4d1607d1eaf6dfa396d64f2d6c1599c/ghc

>---------------------------------------------------------------

commit 816d48a9b4d1607d1eaf6dfa396d64f2d6c1599c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Mar 20 12:38:42 2015 +0000

    Implement lookupGlobal in TcEnv, and use it
    
    This localises the (revolting) initTcForLookup function, exposing
    instead the more civilised interface for lookupGlobal


>---------------------------------------------------------------

816d48a9b4d1607d1eaf6dfa396d64f2d6c1599c
 compiler/coreSyn/CorePrep.hs    | 16 ++++++++++------
 compiler/simplCore/CoreMonad.hs |  9 ++++-----
 compiler/typecheck/TcEnv.hs     | 20 +++++++++++++++++++-
 3 files changed, 33 insertions(+), 12 deletions(-)

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 9f6bb05..2b8ac02 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -30,7 +30,6 @@ import Type
 import Literal
 import Coercion
 import TcEnv
-import TcRnMonad
 import TyCon
 import Demand
 import Var
@@ -57,9 +56,14 @@ import Config
 import Name             ( NamedThing(..), nameSrcSpan )
 import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import Data.Bits
+import MonadUtils       ( mapAccumLM )
 import Data.List        ( mapAccumL )
 import Control.Monad
 
+#if __GLASGOW_HASKELL__ < 711
+import Control.Applicative
+#endif
+
 {-
 -- ---------------------------------------------------------------------------
 -- Overview
@@ -1153,21 +1157,21 @@ data CorePrepEnv = CPE {
 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
 lookupMkIntegerName dflags hsc_env
     = guardIntegerUse dflags $ liftM tyThingId $
-      initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
+      lookupGlobal hsc_env mkIntegerName
 
 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
-    IntegerGMP -> guardIntegerUse dflags $ liftM Just $
-                  initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env integerSDataConName
     IntegerSimple -> return Nothing
 
 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
 guardIntegerUse :: DynFlags -> IO a -> IO a
 guardIntegerUse dflags act
   | thisPackage dflags == primPackageKey
-    = return $ panic "Can't use Integer in ghc-prim"
+  = return $ panic "Can't use Integer in ghc-prim"
   | thisPackage dflags == integerPackageKey
-    = return $ panic "Can't use Integer in integer-*"
+  = return $ panic "Can't use Integer in integer-*"
   | otherwise = act
 
 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 68b613b..0a1c782 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -57,6 +57,7 @@ module CoreMonad (
 
 #ifdef GHCI
 import Name( Name )
+import TcRnMonad        ( initTcForLookup )
 #endif
 import CoreSyn
 import HscTypes
@@ -68,8 +69,7 @@ import Annotations
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
-import TcEnv            ( tcLookupGlobal )
-import TcRnMonad        ( initTcForLookup )
+import TcEnv            ( lookupGlobal )
 import Var
 import Outputable
 import FastString
@@ -886,9 +886,8 @@ dumpIfSet_dyn flag str doc
 -}
 
 instance MonadThings CoreM where
-    lookupThing name = do
-        hsc_env <- getHscEnv
-        liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
+    lookupThing name = do { hsc_env <- getHscEnv
+                          ; liftIO $ lookupGlobal hsc_env name }
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 8db9f26..e39fbf9 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -1,5 +1,4 @@
 -- (c) The University of Glasgow 2006
-
 {-# LANGUAGE CPP, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
 
@@ -19,6 +18,7 @@ module TcEnv(
         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupAxiom,
+        lookupGlobal,
 
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnv2,
@@ -98,6 +98,23 @@ import Maybes( MaybeErr(..) )
 import Data.IORef
 import Data.List
 
+
+{- *********************************************************************
+*                                                                      *
+            An IO interface to looking up globals
+*                                                                      *
+********************************************************************* -}
+
+lookupGlobal :: HscEnv -> Name -> IO TyThing
+-- An IO version, used outside the typechecker
+-- It's more complicated than it looks, because it may
+-- need to suck in an interface file
+lookupGlobal hsc_env name
+  = initTcForLookup hsc_env (tcLookupGlobal name)
+    -- This initTcForLookup stuff is massive overkill
+    -- but that's how it is right now, and at least
+    -- this function localises it
+
 {-
 ************************************************************************
 *                                                                      *
@@ -110,6 +127,7 @@ unless you know that the SrcSpan in the monad is already set to the
 span of the Name.
 -}
 
+
 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
 -- c.f. IfaceEnvEnv.tcIfaceGlobal
 tcLookupLocatedGlobal name