1 files changed, 50 insertions, 2 deletions
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
index c064c0e833..3e0facf97b 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