Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Use TemplateHaskellQuotes for Name lookup #53

Merged
merged 1 commit into from
Apr 29, 2024
Merged

Use TemplateHaskellQuotes for Name lookup #53

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions ghc-typelits-extra.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,6 +84,7 @@ library
hs-source-dirs: src-pre-ghc-9.4
if impl(ghc >= 9.4) && impl(ghc < 9.10)
hs-source-dirs: src-ghc-9.4
build-depends: template-haskell >= 2.17 && <2.22
default-language: Haskell2010
other-extensions: DataKinds
FlexibleInstances
Expand Down
55 changes: 30 additions & 25 deletions src-ghc-9.4/GHC/TypeLits/Extra/Solver.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ pragma to the header of your file

{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

{-# OPTIONS_HADDOCK show-extensions #-}

Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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:
--
Expand Down Expand Up @@ -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
Expand Down
Loading