diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`ghc-typelits-natnormalise`](http://hackage.haskell.org/package/ghc-typelits-natnormalise) package +## 0.7.8 *February 20th 2023* +* Try and outright solve substituted constraints, the same as is done with the unsubstituted constraint. Partially Fixes [#65](https://github.com/clash-lang/ghc-typelits-natnormalise/issues/65). +* Support for GHC-9.6.0.20230210 + ## 0.7.7 *October 10th 2022* * Solve unflattened wanteds instead of the wanteds passed to the plugin. Fixes [#1901]https://github.com/clash-lang/clash-compiler/issues/1901. * Add support for GHC 9.4 diff --git a/ghc-typelits-natnormalise.cabal b/ghc-typelits-natnormalise.cabal --- a/ghc-typelits-natnormalise.cabal +++ b/ghc-typelits-natnormalise.cabal @@ -1,5 +1,5 @@ name: ghc-typelits-natnormalise -version: 0.7.7 +version: 0.7.8 synopsis: GHC typechecker plugin for types of kind GHC.TypeLits.Nat description: A type checker plugin for GHC that can solve /equalities/ and /inequalities/ @@ -49,8 +49,8 @@ CHANGELOG.md cabal-version: >=1.10 tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, - GHC == 9.4.2 + GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.6, + GHC == 9.4.4, GHC == 9.6.1 source-repository head type: git @@ -68,9 +68,9 @@ GHC.TypeLits.Normalise.Unify build-depends: base >=4.9 && <5, containers >=0.5.7.1 && <0.7, - ghc >=8.0.1 && <9.6, + ghc >=8.0.1 && <9.8, ghc-tcplugins-extra >=0.3.1, - transformers >=0.5.2.0 && < 0.6 + transformers >=0.5.2.0 && < 0.7 if impl(ghc >= 9.0.0) build-depends: ghc-bignum >=1.0 && <1.4 else @@ -78,7 +78,7 @@ hs-source-dirs: src if impl(ghc >= 8.0) && impl(ghc < 9.4) hs-source-dirs: src-pre-ghc-9.4 - if impl(ghc >= 9.4) && impl(ghc < 9.6) + if impl(ghc >= 9.4) && impl(ghc < 9.8) hs-source-dirs: src-ghc-9.4 default-language: Haskell2010 other-extensions: CPP diff --git a/src-ghc-9.4/GHC/TypeLits/Normalise.hs b/src-ghc-9.4/GHC/TypeLits/Normalise.hs --- a/src-ghc-9.4/GHC/TypeLits/Normalise.hs +++ b/src-ghc-9.4/GHC/TypeLits/Normalise.hs @@ -143,6 +143,7 @@ where /n-l/ is a negative number. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -185,8 +186,15 @@ mkPrimEqPred, isEqPred, isEqPrimPred, getClassPredTys_maybe) import GHC.Core.TyCo.Rep (Type (..), UnivCoProvenance (..)) import GHC.Core.TyCon (TyCon) +#if MIN_VERSION_ghc(9,6,0) import GHC.Core.Type + (Kind, PredType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) +import GHC.Core.TyCo.Compare + (eqType) +#else +import GHC.Core.Type (Kind, PredType, eqType, mkTyVarTy, tyConAppTyCon_maybe, typeKind, mkTyConApp) +#endif import GHC.Driver.Plugins (Plugin (..), defaultPlugin, purePlugin) import GHC.Tc.Plugin (TcPluginM, tcLookupClass, tcPluginTrace, tcPluginIO, newEvVar) @@ -514,6 +522,7 @@ -- `1 <= x^y` -- OR (instantSolveIneq depth u: + instantSolveIneq depth uS: -- This inequality is either a given constraint, or it is a wanted -- constraint, which in normal form is equal to another given -- constraint, hence it can be solved. diff --git a/src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs b/src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs --- a/src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs +++ b/src-pre-ghc-9.4/GHC/TypeLits/Normalise.hs @@ -659,6 +659,7 @@ -- `1 <= x^y` -- OR (instantSolveIneq depth u: + instantSolveIneq depth uS: -- This inequality is either a given constraint, or it is a wanted -- constraint, which in normal form is equal to another given -- constraint, hence it can be solved. diff --git a/src/GHC/TypeLits/Normalise/Unify.hs b/src/GHC/TypeLits/Normalise/Unify.hs --- a/src/GHC/TypeLits/Normalise/Unify.hs +++ b/src/GHC/TypeLits/Normalise/Unify.hs @@ -73,8 +73,15 @@ #endif import GHC.Core.Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType, mkPrimEqPred) import GHC.Core.TyCon (TyCon) +#if MIN_VERSION_ghc(9,6,0) import GHC.Core.Type + (PredType, TyVar, coreView, mkNumLitTy, mkTyConApp, mkTyVarTy, typeKind) +import GHC.Core.TyCo.Compare + (eqType, nonDetCmpType) +#else +import GHC.Core.Type (PredType, TyVar, coreView, eqType, mkNumLitTy, mkTyConApp, mkTyVarTy, nonDetCmpType, typeKind) +#endif import GHC.Core.TyCo.Rep (Kind, Type (..), TyLit (..)) import GHC.Tc.Plugin (TcPluginM, tcPluginTrace) import GHC.Tc.Types.Constraint (Ct, ctEvidence, ctEvId, ctEvPred, isGiven) diff --git a/tests/ErrorTests.hs b/tests/ErrorTests.hs --- a/tests/ErrorTests.hs +++ b/tests/ErrorTests.hs @@ -191,7 +191,7 @@ testProxy10 = proxyInEq' testProxy10Errors = -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 906 [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" @@ -199,6 +199,23 @@ ) ,$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "(CmpNat a (a + 2)) True True False’" + else litE $ stringL "(CmpNat a (a + 2)) True True False'" + ) + ,$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "with ‘False" + else litE $ stringL "with False" + ) + ] +#elif __GLASGOW_HASKELL__ >= 902 + [$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" + else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" + ) + ,$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "(CmpNat a (a + 2)) 'True 'True 'False’" else litE $ stringL "(CmpNat a (a + 2)) 'True 'True 'False'" ) @@ -222,8 +239,13 @@ testProxy11Errors = [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 +#if __GLASGOW_HASKELL__ >= 906 + then litE $ stringL "Couldn't match type ‘True’ with ‘False’" + else litE $ stringL "Couldn't match type True with False" +#else then litE $ stringL "Couldn't match type ‘'True’ with ‘'False’" else litE $ stringL "Couldn't match type 'True with 'False" +#endif )] testProxy12 :: Proxy (a + b) -> Proxy (a + c) -> () @@ -292,7 +314,24 @@ testProxy14 = proxyInEq' testProxy14Errors = -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 906 + [$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" + else litE $ stringL "Couldn't match type `Data.Type.Ord.OrdCond" + ) + ,$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False’" + else litE $ stringL "(CmpNat (2 * a) (4 * a)) True True False'" + ) + ,$(do localeEncoding <- runIO (getLocaleEncoding) + if textEncodingName localeEncoding == textEncodingName utf8 + then litE $ stringL "with ‘False" + else litE $ stringL "with False" + ) + ] +#elif __GLASGOW_HASKELL__ >= 902 [$(do localeEncoding <- runIO (getLocaleEncoding) if textEncodingName localeEncoding == textEncodingName utf8 then litE $ stringL "Couldn't match type ‘Data.Type.Ord.OrdCond" diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -25,6 +25,10 @@ {-# OPTIONS_GHC -dcore-lint #-} import GHC.TypeLits +#if MIN_VERSION_base(4,18,0) + hiding (type SNat) +#endif + import Unsafe.Coerce import Prelude hiding (head,tail,init,(++),splitAt,concat,drop) import qualified Prelude as P @@ -498,6 +502,12 @@ tyFamMonotonicity :: (2 <= F2 dom) => Proxy (dom :: Symbol) -> () tyFamMonotonicity dom = tyFamMonotonicityFun dom +oneLtPowSubst :: forall a b. (b ~ (2^a)) => Proxy a -> Proxy a +oneLtPowSubst = go + where + go :: 1 <= b => Proxy a -> Proxy a + go = id + main :: IO () main = defaultMain tests @@ -598,6 +608,9 @@ , testCase "2 <= P (G2 dom) implies 1 <= P (G2 dom)" $ show (tyFamMonotonicity (Proxy :: Proxy Dom)) @?= "()" + , testCase "b ~ (2^a) => 1 <= b" $ + show (oneLtPowSubst (Proxy :: Proxy 0)) @?= + "Proxy" ] , testGroup "errors" [ testCase "x + 2 ~ 3 + x" $ testProxy1 `throws` testProxy1Errors