From d7b914b50cdd88a338fa6881078b1879762d1235 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 29 Apr 2024 14:37:01 -0400
Subject: [PATCH] Use TemplateHaskellQuotes for Name lookup
Adds support for GHC 9.10 by making name resolution less dependent upon
the internal structure of `base`.
---
ghc-typelits-extra.cabal | 1 +
src-ghc-9.4/GHC/TypeLits/Extra/Solver.hs | 55 +++++++++++++-----------
2 files changed, 31 insertions(+), 25 deletions(-)
diff --git a/ghc-typelits-extra.cabal b/ghc-typelits-extra.cabal
index 1c4147d..3a07f6a 100644
--- 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.22,
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
index 8fe3db5..8d2ed0e 100644
--- 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