[commit: ghc] wip/14691: Try using tcLookup instead of tcLookupGlobal (cb7deb6)

[git at git.haskell.org]

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

On branch  : wip/14691
Link       : http://ghc.haskell.org/trac/ghc/changeset/cb7deb6d0f36132594ccad3c86bddc7d7cdbb0dd/ghc

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

commit cb7deb6d0f36132594ccad3c86bddc7d7cdbb0dd
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sun Jan 21 18:32:32 2018 -0500

    Try using tcLookup instead of tcLookupGlobal


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

cb7deb6d0f36132594ccad3c86bddc7d7cdbb0dd
 compiler/typecheck/TcEnv.hs    | 11 ++++++++++-
 compiler/typecheck/TcErrors.hs | 16 +++++++++++++++-
 compiler/typecheck/TcEvTerm.hs | 28 +++++++---------------------
 compiler/typecheck/TcSMonad.hs |  7 +++++--
 4 files changed, 37 insertions(+), 25 deletions(-)

diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 28130b7..0520296 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -34,7 +34,7 @@ module TcEnv(
         isTypeClosedLetBndr,
 
         tcLookup, tcLookupLocated, tcLookupLocalIds,
-        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
+        tcLookupId, tcLookupIdMaybe, tcLookupTyVar, tcLookupTyConLocal,
         tcLookupLcl_maybe,
         getInLocalScope,
         wrongThingErr, pprBinders,
@@ -365,6 +365,15 @@ tcLookupIdMaybe name
            AGlobal (AnId id)    -> return $ Just id
            _                    -> return Nothing }
 
+tcLookupTyConLocal :: Name -> TcM TyCon
+tcLookupTyConLocal name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATcTyCon tycon         -> return tycon
+           AGlobal (ATyCon tycon) -> return tycon
+           _                      -> pprPanic "tcLookupTyCon" (ppr thing) }
+
+
 tcLookupLocalIds :: [Name] -> TcM [TcId]
 -- We expect the variables to all be bound, and all at
 -- the same level as the lookup.  Only used in one place...
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 2f8f4cf..70f8b20 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -31,7 +31,6 @@ import TyCon
 import Class
 import DataCon
 import TcEvidence
-import TcEvTerm
 import HsExpr  ( UnboundVar(..) )
 import HsBinds ( PatSynBind(..) )
 import Name
@@ -61,6 +60,10 @@ import Pair
 import qualified GHC.LanguageExtensions as LangExt
 import FV ( fvVarList, fvVarSet, unionFV )
 
+import CoreSyn
+import MkCore
+import Literal
+
 import Control.Monad    ( when )
 import Data.Foldable    ( toList )
 import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr, foldl')
@@ -3151,3 +3154,14 @@ solverDepthErrorTcS loc ty
       , text "(any upper bound you could choose might fail unpredictably with"
       , text " minor updates to GHC, so disabling the check is recommended if"
       , text " you're sure that type checking should terminate)" ]
+
+
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in TcSimplify
+evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError ty msg
+  = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
+  where
+    errorId = tYPE_ERROR_ID
+    litMsg  = Lit (MachStr (fastStringToByteString msg))
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
index 21cce3b..e9d3db3 100644
--- a/compiler/typecheck/TcEvTerm.hs
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -1,20 +1,17 @@
 
 -- (those who have too heavy dependencies for TcEvidence)
 module TcEvTerm
-    ( evDelayedError, evCallStack, evTypeable)
-
+    ( evCallStack, evTypeable)
 where
 
 import GhcPrelude
 
-import FastString
+import TcSMonad
 import Type
 import CoreSyn
 import MkCore
-import Literal ( Literal(..) )
 import TcEvidence
 import HscTypes
-import DynFlags
 import Name
 import Module
 import CoreUtils
@@ -26,19 +23,8 @@ import MkId
 import TysWiredIn
 import Control.Monad (zipWithM)
 
--- Used with Opt_DeferTypeErrors
--- See Note [Deferring coercion errors to runtime]
--- in TcSimplify
-evDelayedError :: Type -> FastString -> EvTerm
-evDelayedError ty msg
-  = Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
-  where
-    errorId = tYPE_ERROR_ID
-    litMsg  = Lit (MachStr (fastStringToByteString msg))
-
 -- Dictionary for CallStack implicit parameters
-evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
-    EvCallStack -> m CoreExpr
+evCallStack :: EvCallStack -> TcS CoreExpr
 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
 evCallStack cs = do
   df            <- getDynFlags
@@ -74,12 +60,12 @@ evCallStack cs = do
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
     EvCsEmpty -> return emptyCS
 
-evTypeable :: MonadThings m => Type -> EvTypeable -> m CoreExpr
+evTypeable :: Type -> EvTypeable -> TcS CoreExpr
 -- Return a CoreExpr :: Typeable ty
 -- This code is tightly coupled to the representation
 -- of TypeRep, in base library Data.Typeable.Internals
 evTypeable ty ev
-  = do { tyCl <- lookupTyCon typeableClassName    -- Typeable
+  = do { tyCl <- tcLookupTyCon typeableClassName    -- Typeable
        ; let kind = typeKind ty
              Just typeable_data_con
                  = tyConSingleDataCon_maybe tyCl    -- "Data constructor"
@@ -93,11 +79,11 @@ evTypeable ty ev
 type TypeRepExpr = CoreExpr
 
 -- | Returns a @CoreExpr :: TypeRep ty@
-ds_ev_typeable :: MonadThings m => Type -> EvTypeable -> m CoreExpr
+ds_ev_typeable :: Type -> EvTypeable -> TcS CoreExpr
 ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
   = do { mkTrCon <- lookupId mkTrConName
                     -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
-       ; someTypeRepTyCon <- lookupTyCon someTypeRepTyConName
+       ; someTypeRepTyCon <- tcLookupTyCon someTypeRepTyConName
        ; someTypeRepDataCon <- lookupDataCon someTypeRepDataConName
                     -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
 
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 14e010d..70640c4 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -43,7 +43,7 @@ module TcSMonad (
     getTopEnv, getGblEnv, getLclEnv,
     getTcEvBindsVar, getTcLevel,
     getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
-    tcLookupClass, tcLookupId,
+    tcLookupClass, tcLookupId, tcLookupTyCon,
 
     -- Inerts
     InertSet(..), InertCans(..),
@@ -128,7 +128,7 @@ import FamInstEnv
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM
-       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )
+       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId, tcLookupTyConLocal )
 import PrelNames( heqTyConKey, eqTyConKey )
 import Kind
 import TcType
@@ -2781,6 +2781,9 @@ tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
 tcLookupId :: Name -> TcS Id
 tcLookupId n = wrapTcS $ TcM.tcLookupId n
 
+tcLookupTyCon :: Name -> TcS TyCon
+tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyConLocal n
+
 -- Setting names as used (used in the deriving of Coercible evidence)
 -- Too hackish to expose it to TcS? In that case somehow extract the used
 -- constructors from the result of solveInteract