diff --git a/CHANGELOG.md b/CHANGELOG.md index 7a56189..bef68e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.5 +* Add `evByFiatWithDependencies`, see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037 for more details. +* Added support for GHC 9.11.20240522 + ## 0.4.6 *May 22nd 2024* * Added support for GHC-9.10.1 * Removed support for GHC 7.10 diff --git a/defaults.dhall b/defaults.dhall index 862ca95..37ba8ad 100644 --- a/defaults.dhall +++ b/defaults.dhall @@ -1,5 +1,5 @@ { name = "ghc-tcplugins-extra" -, version = "0.4.6" +, version = "0.5" , synopsis = "Utilities for writing GHC type-checker plugins" , description = '' diff --git a/ghc-tcplugins-extra.cabal b/ghc-tcplugins-extra.cabal index 12623c4..15d1471 100644 --- a/ghc-tcplugins-extra.cabal +++ b/ghc-tcplugins-extra.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: ghc-tcplugins-extra -version: 0.4.6 +version: 0.5 synopsis: Utilities for writing GHC type-checker plugins description: Utilities for writing GHC type-checker plugins, such as creating constraints, with a stable API covering multiple @@ -55,7 +55,20 @@ library ghc-options: -fhide-source-paths if flag(deverror) ghc-options: -Werror - if impl(ghc >= 9.10) && impl(ghc < 9.12) + if impl(ghc >= 9.11) && impl(ghc < 9.13) + other-modules: + GhcApi.Constraint + GhcApi.Predicate + GhcApi.GhcPlugins + Internal.Type + Internal.Constraint + Internal.Evidence + hs-source-dirs: + src-ghc-tree-9.4 + src-ghc-9.12 + build-depends: + ghc >=9.11 && <9.13 + if impl(ghc >= 9.10) && impl(ghc < 9.11) other-modules: GhcApi.Constraint GhcApi.Predicate @@ -67,7 +80,7 @@ library src-ghc-tree-9.4 src-ghc-9.10 build-depends: - ghc >=9.10 && <9.12 + ghc ==9.10.* if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: GhcApi.Constraint diff --git a/package.dhall b/package.dhall index bbeae32..2b9994b 100644 --- a/package.dhall +++ b/package.dhall @@ -30,7 +30,8 @@ in let ghc = { name = "ghc", mixin = [] : List Text } , exposed-modules = "GHC.TcPluginM.Extra" , other-modules = "Internal" , when = - [ version "9.10" "9.12" [ "tree-9.4", "9.10" ] ghc mods + [ version "9.11" "9.13" [ "tree-9.4", "9.12" ] ghc mods + , version "9.10" "9.11" [ "tree-9.4", "9.10" ] ghc mods , version "9.8" "9.10" [ "tree-9.4", "9.8" ] ghc mods , version "9.4" "9.8" [ "tree-9.4", "9.4" ] ghc mods , version "9.2" "9.4" [ "tree", "9.2" ] ghc mods diff --git a/src-ghc-9.12/GhcApi/Constraint.hs b/src-ghc-9.12/GhcApi/Constraint.hs new file mode 100644 index 0000000..98b32db --- /dev/null +++ b/src-ghc-9.12/GhcApi/Constraint.hs @@ -0,0 +1,13 @@ +module GhcApi.Constraint + ( Ct(..) + , CtEvidence(..) + , CtLoc + , CanEqLHS(..) + , ctLoc + , ctEvId + , mkNonCanonical + ) +where + +import GHC.Tc.Types.Constraint + (Ct (..), CtEvidence (..), CanEqLHS (..), CtLoc, ctLoc, ctEvId, mkNonCanonical) diff --git a/src-ghc-9.12/GhcApi/GhcPlugins.hs b/src-ghc-9.12/GhcApi/GhcPlugins.hs new file mode 100644 index 0000000..c87fa3e --- /dev/null +++ b/src-ghc-9.12/GhcApi/GhcPlugins.hs @@ -0,0 +1,5 @@ +module GhcApi.GhcPlugins (module GHC.Plugins, FindResult(..), findPluginModule) where + +import GHC.Plugins hiding (TcPlugin) +import GHC.Unit.Finder (findPluginModule) +import GHC.Tc.Plugin (FindResult(..)) diff --git a/src-ghc-9.12/Internal/Constraint.hs b/src-ghc-9.12/Internal/Constraint.hs new file mode 100644 index 0000000..515f677 --- /dev/null +++ b/src-ghc-9.12/Internal/Constraint.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} + +module Internal.Constraint (newGiven, flatToCt, mkSubst, overEvidencePredType) where + +import GhcApi.GhcPlugins +import GhcApi.Constraint + (Ct(..), CtEvidence(..), CanEqLHS(..), CtLoc, ctLoc, ctEvId, mkNonCanonical) + +import GHC.Tc.Utils.TcType (TcType) +import GHC.Tc.Types.Constraint (DictCt(..), IrredCt(..), EqCt(..), QCInst(..)) +import GHC.Tc.Types.Evidence (EvTerm(..), EvBindsVar) +import GHC.Tc.Plugin (TcPluginM) +import qualified GHC.Tc.Plugin as TcPlugin (newGiven) + +-- | Create a new [G]iven constraint, with the supplied evidence. This must not +-- be invoked from 'tcPluginInit' or 'tcPluginStop', or it will panic. +newGiven :: EvBindsVar -> CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence +newGiven tcEvbinds loc pty (EvExpr ev) = TcPlugin.newGiven tcEvbinds loc pty ev +newGiven _ _ _ ev = panicDoc "newGiven: not an EvExpr: " (ppr ev) + +flatToCt :: [((TcTyVar,TcType),Ct)] -> Maybe Ct +flatToCt [((_,lhs),ct),((_,rhs),_)] + = Just + $ mkNonCanonical + $ CtGiven (mkPrimEqPred lhs rhs) + (ctEvId ct) + (ctLoc ct) + +flatToCt _ = Nothing + +-- | Create simple substitution from type equalities +mkSubst :: Ct -> Maybe ((TcTyVar, TcType),Ct) +mkSubst ct@(CEqCan (EqCt {..})) + | TyVarLHS tyvar <- eq_lhs + = Just ((tyvar,eq_rhs),ct) +mkSubst _ = Nothing + +-- | Modify the predicate type of the evidence term of a constraint +overEvidencePredType :: (TcType -> TcType) -> Ct -> Ct +overEvidencePredType f (CDictCan di) = + let + ev :: CtEvidence + ev = di_ev di + in CDictCan ( di { di_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CIrredCan ir) = + let + ev :: CtEvidence + ev = ir_ev ir + in CIrredCan ( ir { ir_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CEqCan eq) = + let + ev :: CtEvidence + ev = eq_ev eq + in CEqCan ( eq { eq_ev = ev { ctev_pred = f (ctev_pred ev) } } ) +overEvidencePredType f (CNonCanonical ct) = + let + ev :: CtEvidence + ev = ct + in CNonCanonical ( ev { ctev_pred = f (ctev_pred ev) } ) +overEvidencePredType f (CQuantCan qci) = + let + ev :: CtEvidence + ev = qci_ev qci + in CQuantCan ( qci { qci_ev = ev { ctev_pred = f (ctev_pred ev) } } ) diff --git a/src-ghc-9.12/Internal/Evidence.hs b/src-ghc-9.12/Internal/Evidence.hs new file mode 100644 index 0000000..1b48544 --- /dev/null +++ b/src-ghc-9.12/Internal/Evidence.hs @@ -0,0 +1,26 @@ +module Internal.Evidence (evByFiat, evByFiatWithDependencies) where + +import GHC.Tc.Types.Evidence (EvTerm(..)) +import GHC.Core.TyCo.Rep (UnivCoProvenance (..)) + +import GhcApi.GhcPlugins + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiat :: String -- ^ Name the coercion should have + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiat name t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name emptyDVarSet) Nominal t1 t2 +{-# DEPRECATED evByFiat "'evByFiat' creates proofs that can lead to unsoundness, use 'evByFiatWithDependencies' instead.\nSee also https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12037" #-} + +-- | The 'EvTerm' equivalent for 'Unsafe.unsafeCoerce' +evByFiatWithDependencies :: + String -- ^ Name the coercion should have + -> DCoVarSet -- ^ The set of all the in-scope coercion variables + -- that the proof makes use of. + -> Type -- ^ The LHS of the equivalence relation (~) + -> Type -- ^ The RHS of the equivalence relation (~) + -> EvTerm +evByFiatWithDependencies name deps t1 t2 = + EvExpr $ Coercion $ mkUnivCo (PluginProv name deps) Nominal t1 t2 diff --git a/src-ghc-9.12/Internal/Type.hs b/src-ghc-9.12/Internal/Type.hs new file mode 100644 index 0000000..39fb06a --- /dev/null +++ b/src-ghc-9.12/Internal/Type.hs @@ -0,0 +1,30 @@ +module Internal.Type (substType) where + +import Data.Maybe (fromMaybe) +import GHC.Tc.Utils.TcType (TcType) +import GHC.Core.TyCo.Rep (Type (..)) +import GHC.Types.Var (TcTyVar) + +-- | Apply substitutions in Types +-- +-- __NB:__ Doesn't substitute under binders +substType + :: [(TcTyVar, TcType)] + -> TcType + -> TcType +substType subst tv@(TyVarTy v) = + fromMaybe tv (lookup v subst) +substType subst (AppTy t1 t2) = + AppTy (substType subst t1) (substType subst t2) +substType subst (TyConApp tc xs) = + TyConApp tc (map (substType subst) xs) +substType _subst t@(ForAllTy _tv _ty) = + -- TODO: Is it safe to do "dumb" substitution under binders? + -- ForAllTy tv (substType subst ty) + t +substType subst (FunTy k1 k2 t1 t2) = + FunTy k1 k2 (substType subst t1) (substType subst t2) +substType _ l@(LitTy _) = l +substType subst (CastTy ty co) = + CastTy (substType subst ty) co +substType _ co@(CoercionTy _) = co