[commit: ghc] master: Make CoreMonad independent of TcEnv (#14391) (03b779f)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/03b779f2444c438204789c7ced0ed23556f7b105/ghc

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

commit 03b779f2444c438204789c7ced0ed23556f7b105
Author: Krzysztof Gogolewski <krz.gogolewski at gmail.com>
Date:   Tue Sep 11 20:46:04 2018 +0200

    Make CoreMonad independent of TcEnv (#14391)
    
    Summary:
    This removes the last direct import from simplCore/
    to typechecker/.
    
    Test Plan: validate
    
    Reviewers: nomeata, simonpj, bgamari
    
    Reviewed By: simonpj
    
    Subscribers: rwbarton, carter
    
    GHC Trac Issues: #14391
    
    Differential Revision: https://phabricator.haskell.org/D5139


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

03b779f2444c438204789c7ced0ed23556f7b105
 compiler/main/GhcPlugins.hs     | 52 +++++++++++++++++++++++++++++++++++++--
 compiler/simplCore/CoreMonad.hs | 54 +----------------------------------------
 2 files changed, 51 insertions(+), 55 deletions(-)

diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
index c064c0e..3e0facf 100644
--- a/compiler/main/GhcPlugins.hs
+++ b/compiler/main/GhcPlugins.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
 
 -- | This module is not used by GHC itself.  Rather, it exports all of
 -- the functions and types you are likely to need when writing a
@@ -19,7 +19,10 @@ module GhcPlugins(
         module VarSet, module VarEnv, module NameSet, module NameEnv,
         module UniqSet, module UniqFM, module FiniteMap,
         module Util, module GHC.Serialized, module SrcLoc, module Outputable,
-        module UniqSupply, module Unique, module FastString
+        module UniqSupply, module Unique, module FastString,
+
+        -- * Getting 'Name's
+        thNameToGhcName
     ) where
 
 -- Plugin stuff itself
@@ -82,3 +85,48 @@ import Outputable
 import UniqSupply
 import Unique           ( Unique, Uniquable(..) )
 import FastString
+import Data.Maybe
+
+import NameCache (lookupOrigNameCache)
+import GhcPrelude
+import MonadUtils       ( mapMaybeM )
+import Convert          ( thRdrNameGuesses )
+import TcEnv            ( lookupGlobal )
+
+import qualified Language.Haskell.TH as TH
+
+{- This instance is defined outside CoreMonad.hs so that
+   CoreMonad does not depend on TcEnv -}
+instance MonadThings CoreM where
+    lookupThing name = do { hsc_env <- getHscEnv
+                          ; liftIO $ lookupGlobal hsc_env name }
+
+{-
+************************************************************************
+*                                                                      *
+               Template Haskell interoperability
+*                                                                      *
+************************************************************************
+-}
+
+-- | Attempt to convert a Template Haskell name to one that GHC can
+-- understand. Original TH names such as those you get when you use
+-- the @'foo@ syntax will be translated to their equivalent GHC name
+-- exactly. Qualified or unqualified TH names will be dynamically bound
+-- to names in the module being compiled, if possible. Exact TH names
+-- will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference
+          -- to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+      = return $ if isExternalName n then Just n else Nothing
+      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+      = do { cache <- getOrigNameCache
+           ; return $ lookupOrigNameCache cache rdr_mod rdr_occ }
+      | otherwise = return Nothing
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 6b7393c..0c5d8d9 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -47,17 +47,11 @@ module CoreMonad (
     putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
-
-    -- * Getting 'Name's
-    thNameToGhcName
+    dumpIfSet_dyn
   ) where
 
 import GhcPrelude hiding ( read )
 
-import Convert
-import RdrName
-import Name
 import CoreSyn
 import HscTypes
 import Module
@@ -67,7 +61,6 @@ import Annotations
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
-import TcEnv            ( lookupGlobal )
 import Var
 import Outputable
 import FastString
@@ -82,7 +75,6 @@ import Data.List
 import Data.Ord
 import Data.Dynamic
 import Data.IORef
-import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Map.Strict as MapStrict
@@ -90,8 +82,6 @@ import Data.Word
 import Control.Monad
 import Control.Applicative ( Alternative(..) )
 
-import qualified Language.Haskell.TH as TH
-
 {-
 ************************************************************************
 *                                                                      *
@@ -852,45 +842,3 @@ dumpIfSet_dyn flag str doc
        ; unqual <- getPrintUnqualified
        ; when (dopt flag dflags) $ liftIO $
          Err.dumpSDoc dflags unqual flag str doc }
-
-{-
-************************************************************************
-*                                                                      *
-               Finding TyThings
-*                                                                      *
-************************************************************************
--}
-
-instance MonadThings CoreM where
-    lookupThing name = do { hsc_env <- getHscEnv
-                          ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-*                                                                      *
-               Template Haskell interoperability
-*                                                                      *
-************************************************************************
--}
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name
-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
-          -- Pick the first that works
-          -- E.g. reify (mkName "A") will pick the class A in preference
-          -- to the data constructor A
-        ; return (listToMaybe names) }
-  where
-    lookup rdr_name
-      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-      = return $ if isExternalName n then Just n else Nothing
-      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-      = do { cache <- getOrigNameCache
-           ; return $ lookupOrigNameCache cache rdr_mod rdr_occ }
-      | otherwise = return Nothing