diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,10 @@ # Changelog +## 0.7.4.0 + +* Supports GHC 9.10 +* Drops GHC <9.2 + ## 0.7.3.0 * Supports GHC 9.8 diff --git a/ghc-typelits-presburger.cabal b/ghc-typelits-presburger.cabal --- a/ghc-typelits-presburger.cabal +++ b/ghc-typelits-presburger.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack -- --- hash: 979226dcc13643574c669d5607b3d16d2cb873154282a49ef47bfd9c8b52c073 +-- hash: f52bad218d1394e10b8a760cdc99d47bb03d4ea2f2949d4afcf3da8711c53c60 name: ghc-typelits-presburger -version: 0.7.3.0 +version: 0.7.4.0 synopsis: Presburger Arithmetic Solver for GHC Type-level natural numbers. description: @ghc-typelits-presburger@ augments GHC type-system with Presburger Arithmetic Solver for Type-level natural numbers. @@ -30,7 +30,7 @@ license: BSD3 license-file: LICENSE tested-with: - GHC==9.0.2 GHC==9.2.7 GHC==9.4.4 GHC==9.6.3 GHC==9.8.1 + GHC==9.2.8 GHC==9.4.8 GHC==9.6.5 GHC==9.8.2 GHC==9.10.1 extra-source-files: Changelog.md build-type: Simple @@ -59,7 +59,7 @@ build-depends: base >=4.7 && <5 , containers - , ghc <9.9 + , ghc <9.11 , ghc-tcplugins-extra >=0.2 && <0.5 , mtl , pretty diff --git a/src/GHC/TypeLits/Presburger/Compat.hs b/src/GHC/TypeLits/Presburger/Compat.hs --- a/src/GHC/TypeLits/Presburger/Compat.hs +++ b/src/GHC/TypeLits/Presburger/Compat.hs @@ -9,11 +9,22 @@ module GHC.TypeLits.Presburger.Compat (module GHC.TypeLits.Presburger.Compat) where +import GHC.TypeLits.Presburger.Flags import Data.Coerce (coerce) import Data.Function (on) import Data.Functor ((<&>)) import Data.Generics.Twins -import GHC.Builtin.Names as GHC.TypeLits.Presburger.Compat (gHC_TYPENATS) +import qualified GHC.Types.Unique as Unique (getKey, Unique) +import GHC.Types.Unique as GHC.TypeLits.Presburger.Compat (Unique, getUnique) +#if MIN_VERSION_ghc(9,10,1) +import GHC.Builtin.Names (gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPEERROR) +import GHC.Builtin.Names (mkGhcInternalModule) +#else +import GHC.Builtin.Names (gHC_TYPENATS) +#if MIN_VERSION_ghc(9,4,1) +import GHC.Builtin.Names (gHC_TYPENATS, gHC_TYPEERROR) +#endif +#endif import GHC.Tc.Types.Constraint as GHC.TypeLits.Presburger.Compat (CtLoc (..), initialSubGoalDepth) import GHC.Tc.Types.Origin as GHC.TypeLits.Presburger.Compat (CtOrigin (..)) import GHC.TcPluginM.Extra as GHC.TypeLits.Presburger.Compat ( @@ -33,10 +44,9 @@ import GHC.Tc.Types as GHC.TypeLits.Presburger.Compat (TcPlugin (..), TcPluginResult (..)) #endif #if MIN_VERSION_ghc(9,4,1) -import GHC.Builtin.Names as GHC.TypeLits.Presburger.Compat (mkBaseModule, gHC_TYPEERROR) +import GHC.Builtin.Names as GHC.TypeLits.Presburger.Compat (mkBaseModule) import GHC.Core.Reduction (reductionReducedType) #else -import GHC.Builtin.Names as GHC.TypeLits.Presburger.Compat (dATA_TYPE_EQUALITY) import qualified GHC.Builtin.Names as Old #endif import GHC.Builtin.Types as GHC.TypeLits.Presburger.Compat ( @@ -64,6 +74,7 @@ import GHC.Unit.Types as GHC.TypeLits.Presburger.Compat (mkModule) #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env.Types as GHC.TypeLits.Presburger.Compat (HscEnv (hsc_dflags)) +import GHC.Builtin.Names (mkBaseModule) #else import GHC.Driver.Types as GHC.TypeLits.Presburger.Compat (HscEnv (hsc_dflags)) import GHC.Driver.Session (unitState, unitDatabases) @@ -163,7 +174,6 @@ import GHC.Tc.Utils.TcType as GHC.TypeLits.Presburger.Compat (tcTyFamInsts) import qualified GHC.TcPluginM.Extra as Extra import GHC.Types.Name.Occurrence as GHC.TypeLits.Presburger.Compat (emptyOccSet, mkInstTyTcOcc) -import GHC.Types.Unique as GHC.TypeLits.Presburger.Compat (getKey, getUnique) import GHC.Unit.Module as GHC.TypeLits.Presburger.Compat (ModuleName, mkModuleName) import GHC.Unit.State (UnitState (preloadUnits), initUnits) import GHC.Unit.State as GHC.TypeLits.Presburger.Compat (lookupPackageName) @@ -174,11 +184,26 @@ type TcPluginSolveResult = TcPluginResult #endif -#if MIN_VERSION_ghc(9,4,1) +#if MIN_VERSION_ghc(9,10,1) dATA_TYPE_EQUALITY :: Module +dATA_TYPE_EQUALITY = mkGhcInternalModule "GHC.Internal.Data.Type.Equality" +#else +dATA_TYPE_EQUALITY :: Module dATA_TYPE_EQUALITY = mkBaseModule "Data.Type.Equality" #endif +#if MIN_VERSION_ghc(9,10,1) +gHC_TYPEERROR :: Module +gHC_TYPEERROR = gHC_INTERNAL_TYPEERROR + +gHC_TYPENATS :: Module +gHC_TYPENATS = gHC_INTERNAL_TYPENATS +#elif !MIN_VERSION_ghc(9,4,1) +gHC_TYPEERROR :: Module +gHC_TYPEERROR = mkBaseModule "GHC.TypeLits" +#endif + + type PredTree = Pred data TvSubst = TvSubst InScopeSet TvSubstEnv @@ -242,9 +267,12 @@ getEqWitnessTyCon :: TcPluginM TyCon getEqWitnessTyCon = do - md <- lookupModule (mkModuleName "Data.Type.Equality") (fsLit "base") - tcLookupTyCon =<< lookupOrig md (mkTcOcc ":~:") + tcLookupTyCon =<< lookupOrig dATA_TYPE_EQUALITY (mkTcOcc ":~:") +getEqBoolTyCon :: TcPluginM TyCon +getEqBoolTyCon = do + tcLookupTyCon =<< lookupOrig dATA_TYPE_EQUALITY (mkTcOcc "==") + decompFunTy :: Type -> [Type] decompFunTy (FunTy _ _ t1 t2) = t1 : decompFunTy t2 decompFunTy t = [t] @@ -368,11 +396,16 @@ mtypeNatLeqTyCon = Just typeNatLeqTyCon #endif +dATA_TYPE_ORD :: Module +#if MIN_VERSION_ghc(9,10,0) +dATA_TYPE_ORD = mkGhcInternalModule "GHC.Internal.Data.Type.Ord" +#else +dATA_TYPE_ORD = mkBaseModule "Data.Type.Ord" +#endif + lookupTyNatPredLeq :: TcPluginM Name #if MIN_VERSION_ghc(9,2,0) -lookupTyNatPredLeq = do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - lookupOrig tyOrd (mkTcOcc "<=") +lookupTyNatPredLeq = lookupOrig dATA_TYPE_ORD (mkTcOcc "<=") #else lookupTyNatPredLeq = lookupOrig gHC_TYPENATS (mkTcOcc "<=") @@ -380,9 +413,7 @@ lookupTyNatBoolLeq :: TcPluginM TyCon #if MIN_VERSION_ghc(9,2,0) -lookupTyNatBoolLeq = do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc "<=?") +lookupTyNatBoolLeq = tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc "<=?") #else lookupTyNatBoolLeq = pure typeNatLeqTyCon @@ -402,8 +433,7 @@ -- hence we MUST NOT desugar it with <= 9.2.1 #if MIN_VERSION_ghc(9,2,2) lookupTyNatPredLt = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc "<") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc "<") #else lookupTyNatPredLt = pure Nothing #endif @@ -411,8 +441,7 @@ lookupTyNatBoolLt :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) lookupTyNatBoolLt = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc " do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc ">") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc ">") #else lookupTyNatPredGt = pure Nothing #endif @@ -429,8 +457,7 @@ lookupTyNatBoolGt :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) lookupTyNatBoolGt = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc ">?") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc ">?") #else lookupTyNatBoolGt = pure Nothing #endif @@ -438,8 +465,7 @@ lookupTyNatPredGeq :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) lookupTyNatPredGeq = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc ">=") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc ">=") #else lookupTyNatPredGeq = pure Nothing #endif @@ -447,8 +473,7 @@ lookupTyNatBoolGeq :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) lookupTyNatBoolGeq = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc ">=?") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc ">=?") #else lookupTyNatBoolGeq = pure Nothing #endif @@ -456,8 +481,7 @@ mOrdCondTyCon :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) mOrdCondTyCon = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc "OrdCond") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc "OrdCond") #else mOrdCondTyCon = pure Nothing #endif @@ -465,15 +489,17 @@ lookupTyGenericCompare :: TcPluginM (Maybe TyCon) #if MIN_VERSION_ghc(9,2,0) lookupTyGenericCompare = Just <$> do - tyOrd <- lookupModule (mkModuleName "Data.Type.Ord") "base" - tcLookupTyCon =<< lookupOrig tyOrd (mkTcOcc "Compare") + tcLookupTyCon =<< lookupOrig dATA_TYPE_ORD (mkTcOcc "Compare") #else lookupTyGenericCompare = pure Nothing #endif lookupBool47 :: String -> TcPluginM (Maybe TyCon) -#if MIN_VERSION_base(4,17,0) +#if MIN_VERSION_ghc(9,10,0) lookupBool47 nam = Just <$> do + tcLookupTyCon =<< lookupOrig (mkGhcInternalModule "GHC.Internal.Data.Type.Bool") (mkTcOcc nam) +#elif MIN_VERSION_base(4,17,0) +lookupBool47 nam = Just <$> do tcLookupTyCon =<< lookupOrig (mkBaseModule "Data.Type.Bool") (mkTcOcc nam) #else lookupBool47 = const $ pure Nothing @@ -490,4 +516,22 @@ matchFam' con args = fmap reductionReducedType <$> matchFam con args #else matchFam' con args = fmap snd <$> matchFam con args +#endif + +getKey :: Unique.Unique -> Int +#if MIN_VERSION_ghc(9,10,1) +getKey = fromIntegral . Unique.getKey +#else +getKey = Unique.getKey +#endif + +getVoidTyCon :: TcPluginM TyCon +getVoidTyCon = tcLookupTyCon =<< lookupOrig aMod (mkTcOcc "Void") + where +#if MIN_VERSION_ghc(9,10,1) + aMod = mkGhcInternalModule "GHC.Internal.Base" +#elif MIN_VERSION_ghc(9,6,1) + aMod = mkBaseModule "GHC.Base" +#else + aMod = mkBaseModule "Data.Void" #endif diff --git a/src/GHC/TypeLits/Presburger/Flags.hs b/src/GHC/TypeLits/Presburger/Flags.hs --- a/src/GHC/TypeLits/Presburger/Flags.hs +++ b/src/GHC/TypeLits/Presburger/Flags.hs @@ -5,11 +5,16 @@ data GHCVer = GHC806 | GHC808 | GHC810 - | GHC900 | GHC902 | GHC904 | GHC906 + | GHC900 | GHC902 | GHC904 + | GHC906 | GHC908 | GHC910 deriving (Show, Eq, Ord, Generic) ghcVer :: GHCVer -#if MIN_VERSION_ghc(9,6,1) +#if MIN_VERSION_ghc(9,10,1) +ghcVer = GHC910 +#elif MIN_VERSION_ghc(9,8,1) +ghcVer = GHC908 +#elif MIN_VERSION_ghc(9,6,1) ghcVer = GHC906 #elif MIN_VERSION_ghc(9,4,1) ghcVer = GHC904 diff --git a/src/GHC/TypeLits/Presburger/Types.hs b/src/GHC/TypeLits/Presburger/Types.hs --- a/src/GHC/TypeLits/Presburger/Types.hs +++ b/src/GHC/TypeLits/Presburger/Types.hs @@ -392,14 +392,10 @@ pure ([], []) eqTyCon_ <- getEqTyCon - eqBoolTyCon <- tcLookupTyCon =<< lookupOrig dATA_TYPE_EQUALITY (mkTcOcc "==") + eqBoolTyCon <- getEqBoolTyCon eqWitCon_ <- getEqWitnessTyCon assertTy <- lookupAssertTyCon - vmd <- - if ghcVer >= GHC906 - then lookupModule (mkModuleName "GHC.Base") (fsLit "base") - else lookupModule (mkModuleName "Data.Void") (fsLit "base") - voidTyCon <- tcLookupTyCon =<< lookupOrig vmd (mkTcOcc "Void") + voidTyCon <- getVoidTyCon nLeq <- tcLookupTyCon =<< lookupTyNatPredLeq tyLeqB <- lookupTyNatBoolLeq mTyLtP <- lookupTyNatPredLt diff --git a/test/GHC/TypeLits/PresburgerSpec.hs b/test/GHC/TypeLits/PresburgerSpec.hs --- a/test/GHC/TypeLits/PresburgerSpec.hs +++ b/test/GHC/TypeLits/PresburgerSpec.hs @@ -24,6 +24,7 @@ [ "Could not deduce: (n GHC.TypeNats.+ 1) ~ n" , "Could not deduce ((n GHC.TypeNats.+ 1) ~ n)" , "Could not deduce ‘(n GHC.TypeNats.+ 1) ~ n’" + , "[GHC-25897]" ] -> pure () _ -> assertFailure $ "TypeError with mismatch expected, but got: " <> show eith @@ -35,6 +36,7 @@ [ "Could not deduce: (n GHC.TypeNats.+ 1) ~ n" , "Could not deduce ((n GHC.TypeNats.+ 1) ~ n)" , "Could not deduce ‘(n GHC.TypeNats.+ 1) ~ n’" + , "[GHC-25897]" ] -> pure () _ -> assertFailure $ "TypeError with mismatch expected, but got: " <> show eith ]