Use TemplateHaskellQuotes for Name lookup

Adds support for GHC 9.10 by making name resolution less dependent upon the internal structure of `base`.
clash-lang · Apr 29, 2024 · b5f258f · b5f258f
1 parent 473f7d2
commit b5f258f
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 25 deletions.
diff --git a/ghc-typelits-extra.cabal b/ghc-typelits-extra.cabal
@@ -74,6 +74,7 @@ library
                        ghc-tcplugins-extra       >= 0.3.1,
                        ghc-typelits-knownnat     >= 0.7.2   && <0.8,
                        ghc-typelits-natnormalise >= 0.7.1   && <0.8,
+                       template-haskell          >= 2.17    && <2.21,
                        transformers              >= 0.4.2.0 && <0.7
   if impl(ghc >= 9.0.0)
     build-depends:     ghc-bignum >=1.0 && <1.4

diff --git a/src-ghc-9.4/GHC/TypeLits/Extra/Solver.hs b/src-ghc-9.4/GHC/TypeLits/Extra/Solver.hs
@@ -15,6 +15,7 @@ pragma to the header of your file
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 
 {-# OPTIONS_HADDOCK show-extensions #-}
 
@@ -25,8 +26,9 @@ where
 -- external
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import Data.Maybe (catMaybes)
-import GHC.TcPluginM.Extra
-  (evByFiat, lookupModule, lookupName, tracePlugin, newWanted)
+import GHC.TcPluginM.Extra (evByFiat, tracePlugin, newWanted)
+import qualified Data.Type.Ord
+import qualified GHC.TypeError
 
 -- GHC API
 import GHC.Builtin.Names (eqPrimTyConKey, hasKey, getUnique)
@@ -45,10 +47,12 @@ import GHC.Core.TyCo.Compare (eqType)
 #else
 import GHC.Core.Type (eqType)
 #endif
-import GHC.Data.FastString (fsLit)
+import GHC.Data.IOEnv (getEnv)
+import GHC.Driver.Env (hsc_NC)
 import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin)
-import GHC.Tc.Plugin (TcPluginM, tcLookupTyCon, tcPluginTrace)
-import GHC.Tc.Types (TcPlugin(..), TcPluginSolveResult (..), TcPluginRewriter, TcPluginRewriteResult (..))
+import GHC.Plugins (thNameToGhcNameIO)
+import GHC.Tc.Plugin (TcPluginM, tcLookupTyCon, tcPluginTrace, tcPluginIO, unsafeTcPluginTcM)
+import GHC.Tc.Types (TcPlugin(..), TcPluginSolveResult (..), TcPluginRewriter, TcPluginRewriteResult (..), Env (env_top))
 import GHC.Tc.Types.Constraint
   (Ct, ctEvidence, ctEvPred, ctLoc, isWantedCt)
 #if MIN_VERSION_ghc(9,8,0)
@@ -57,14 +61,17 @@ import GHC.Tc.Types.Constraint (Ct (..), DictCt(..), EqCt(..), IrredCt(..), qci_
 import GHC.Tc.Types.Constraint (Ct (CQuantCan), qci_ev, cc_ev)
 #endif
 import GHC.Tc.Types.Evidence (EvTerm, EvBindsVar, Role(..), evCast, evId)
-import GHC.Types.Name.Occurrence (mkTcOcc)
 import GHC.Types.Unique.FM (UniqFM, listToUFM)
-import GHC.Unit.Module (mkModuleName)
 import GHC.Utils.Outputable (Outputable (..), (<+>), ($$), text)
+import GHC (Name)
+
+-- template-haskell
+import qualified Language.Haskell.TH as TH
 
 -- internal
 import GHC.TypeLits.Extra.Solver.Operations
 import GHC.TypeLits.Extra.Solver.Unify
+import GHC.TypeLits.Extra
 
 -- | A solver implement as a type-checker plugin for:
 --
@@ -309,27 +316,25 @@ fromSolverConstraint (NatInequality ct _ _ _ _) = ct
 
 lookupExtraDefs :: TcPluginM ExtraDefs
 lookupExtraDefs = do
-    md <- lookupModule myModule myPackage
-    md1 <- lookupModule ordModule basePackage
-    md2 <- lookupModule typeErrModule basePackage
-    ExtraDefs <$> look md "Max"
-              <*> look md "Min"
+    ExtraDefs <$> look ''GHC.TypeLits.Extra.Max
+              <*> look ''GHC.TypeLits.Extra.Min
               <*> pure typeNatDivTyCon
               <*> pure typeNatModTyCon
-              <*> look md "FLog"
-              <*> look md "CLog"
-              <*> look md "Log"
-              <*> look md "GCD"
-              <*> look md "LCM"
-              <*> look md1 "OrdCond"
-              <*> look md2 "Assert"
+              <*> look ''GHC.TypeLits.Extra.FLog
+              <*> look ''GHC.TypeLits.Extra.CLog
+              <*> look ''GHC.TypeLits.Extra.Log
+              <*> look ''GHC.TypeLits.Extra.GCD
+              <*> look ''GHC.TypeLits.Extra.LCM
+              <*> look ''Data.Type.Ord.OrdCond
+              <*> look ''GHC.TypeError.Assert
   where
-    look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s)
-    myModule  = mkModuleName "GHC.TypeLits.Extra"
-    myPackage = fsLit "ghc-typelits-extra"
-    ordModule   = mkModuleName "Data.Type.Ord"
-    basePackage = fsLit "base"
-    typeErrModule = mkModuleName "GHC.TypeError"
+    look nm = tcLookupTyCon =<< lookupTHName nm
+
+lookupTHName :: TH.Name -> TcPluginM Name
+lookupTHName th = do
+    nc <- unsafeTcPluginTcM (hsc_NC . env_top <$> getEnv)
+    res <- tcPluginIO $ thNameToGhcNameIO nc th
+    maybe (fail $ "Failed to lookup " ++ show th) return res
 
 -- Utils
 evMagic :: Ct -> Maybe EvTerm