Commit 816d48a9 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Implement lookupGlobal in TcEnv, and use it

This localises the (revolting) initTcForLookup function, exposing
instead the more civilised interface for lookupGlobal
parent 0f3335fe
......@@ -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
......
......@@ -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 }
{-
************************************************************************
......
-- (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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment