diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index 5d67884..b565ff6 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | Instrumentation monad -- -- Intended for unqualified import. @@ -28,12 +26,6 @@ import GHC.Utils.Logger import Plugin.TraceForeignCalls.Options import Plugin.TraceForeignCalls.Util.GHC --- For name resolution -import Debug.Trace qualified -import Control.Exception qualified -import System.IO.Unsafe qualified -import GHC.Stack qualified - {------------------------------------------------------------------------------- Definition -------------------------------------------------------------------------------} @@ -120,12 +112,12 @@ data Names = Names { mkNames :: Names mkNames = Names { - nameTraceEventIO = resolveTHName 'Debug.Trace.traceEventIO - , nameEvaluate = resolveTHName 'Control.Exception.evaluate - , nameUnsafePerformIO = resolveTHName 'System.IO.Unsafe.unsafePerformIO - , nameHasCallStack = resolveTHName ''GHC.Stack.HasCallStack - , nameCallStack = resolveTHName 'GHC.Stack.callStack - , namePrettyCallStack = resolveTHName 'GHC.Stack.prettyCallStack + nameTraceEventIO = resolveVarName "Debug.Trace" "traceEventIO" + , nameEvaluate = resolveVarName "GHC.IO" "evaluate" + , nameUnsafePerformIO = resolveVarName "GHC.IO.Unsafe" "unsafePerformIO" + , nameHasCallStack = resolveTcName "GHC.Stack.Types" "HasCallStack" + , nameCallStack = resolveVarName "GHC.Stack" "callStack" + , namePrettyCallStack = resolveVarName "GHC.Exception" "prettyCallStack" } findName :: (Names -> TcM Name) -> Instrument Name diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs index 48dfaaf..d7060eb 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs @@ -7,12 +7,10 @@ module Plugin.TraceForeignCalls.Util.GHC ( , throwSimpleError , printSimpleWarning -- * Names - , resolveTHName + , resolveVarName + , resolveTcName ) where -import Data.String -import Language.Haskell.TH qualified as TH - import GHC hiding (getNamePprCtx) import GHC.Plugins hiding (getNamePprCtx, getHscEnv) @@ -20,10 +18,10 @@ import GHC.Data.IOEnv import GHC.Driver.Config.Diagnostic import GHC.Driver.Errors import GHC.Driver.Errors.Types +import GHC.Rename.Env import GHC.Runtime.Context import GHC.Tc.Types import GHC.Types.Error -import GHC.Types.Name.Cache import GHC.Utils.Error import GHC.Utils.Logger @@ -51,9 +49,6 @@ getNamePprCtx = getDiagOpts :: HasHscEnv m => m DiagOpts getDiagOpts = initDiagOpts <$> getDynFlags -getNameCache :: HasHscEnv m => m NameCache -getNameCache = hsc_NC <$> getHscEnv - {------------------------------------------------------------------------------- Errors and warnings -------------------------------------------------------------------------------} @@ -91,19 +86,28 @@ printSimpleWarning l doc = do {------------------------------------------------------------------------------- Names + + If we use 'Qual' for the 'RdrName' then the module needs to have that module + imported. We could /add/ the import, but that has problems of its own + (spurious warnings). We therefore use 'Orig'; this does mean we need to + provide a unit, but we only lok things up from base (we'd have to change this + once we have the ghc-internals split). It also means we have to import the + definition from the /defining/ module, rather than it's true "home base" (it's + canonical exporting module). + + A much simpler approach is to depend on TH to resolve names, and use + 'thNameToGhcNameIO'. However, at present the resulting dependency on + @template-haskell@ would make the plugin unuseable for base or the boot + modules. -------------------------------------------------------------------------------} -resolveTHName :: HasHscEnv m => TH.Name -> m Name -resolveTHName name = do - nameCache <- getNameCache - mResolved <- liftIO $ thNameToGhcNameIO nameCache name - case mResolved of - Just name' -> - return name' - Nothing -> - throwSimpleError noSrcSpan $ hcat [ - "Could not resolve TH name " - , fromString $ show name - ] +resolveVarName :: String -> String -> TcM Name +resolveVarName = resolveName mkVarOcc +resolveTcName :: String -> String -> TcM Name +resolveTcName = resolveName mkTcOcc +-- | Internal generalization +resolveName :: (String -> OccName) -> String -> String -> TcM Name +resolveName f modl name = + lookupOccRn $ Orig (mkModule baseUnit (mkModuleName modl)) (f name) diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index 8d270a4..83290bf 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -38,8 +38,6 @@ common lang library import: lang - other-extensions: - TemplateHaskell exposed-modules: Plugin.TraceForeignCalls other-modules: @@ -51,8 +49,7 @@ library build-depends: -- dependencies intentionally kept at a minimum -- (we want to be able to build the boot libs with this plugin) - , ghc >= 9.6 && < 9.7 - , template-haskell >= 2.20 && < 2.21 + , ghc >= 9.6 && < 9.7 test-suite test-trace-foreign-calls import: