[commit: ghc] wip/T9858-typeable-spj: Implement lookupGlobal in TcEnv, and use it (6473d11)

[git at git.haskell.org]

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

On branch  : wip/T9858-typeable-spj
Link       : http://ghc.haskell.org/trac/ghc/changeset/6473d110ab1aa22a5933e405b59e3f597562ce02/ghc

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

commit 6473d110ab1aa22a5933e405b59e3f597562ce02
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


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

6473d110ab1aa22a5933e405b59e3f597562ce02
 compiler/coreSyn/CorePrep.hs    | 20 ++++++++++++--------
 compiler/simplCore/CoreMonad.hs |  9 ++++-----
 compiler/typecheck/TcEnv.hs     | 20 +++++++++++++++++++-
 3 files changed, 35 insertions(+), 14 deletions(-)

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 87b7d16..1e99e80 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,23 +1157,23 @@ 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)
-    IntegerGMP2-> guardIntegerUse dflags $ liftM Just $
-                  initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env integerSDataConName
+    IntegerGMP2-> 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 dec41bb..ae36557 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -56,6 +56,7 @@ module CoreMonad (
 
 #ifdef GHCI
 import Name( Name )
+import TcRnMonad        ( initTcForLookup )
 #endif
 import CoreSyn
 import HscTypes
@@ -67,8 +68,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
@@ -853,9 +853,8 @@ dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
 -}
 
 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 e31ce86..b8324b8 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,
@@ -97,6 +97,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
+
 {-
 ************************************************************************
 *                                                                      *
@@ -109,6 +126,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