From fb94131ac8beaf6167fc2cc5f94602cc881950df Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Fri, 18 Jun 2021 14:18:28 +0200 Subject: [PATCH] Add support for GHC 9.2.0.20210422 --- .github/workflows/haskell-ci.yml | 4 ++++ CHANGELOG.md | 3 +++ ghc-typelits-knownnat.cabal | 10 +++++----- src/GHC/TypeLits/KnownNat.hs | 9 +++++++++ src/GHC/TypeLits/KnownNat/Solver.hs | 22 ++++++++++++++++++++-- 5 files changed, 41 insertions(+), 7 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index db82d97..16f9e74 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -26,6 +26,10 @@ jobs: strategy: matrix: include: + - compiler: ghc-9.2.0.20210422 + ghc: 9.2.0.20210422 + allow-failure: false + ghc-source: ghcup - compiler: ghc-9.0.1 allow-failure: false ghc-source: ppa diff --git a/CHANGELOG.md b/CHANGELOG.md index 72ad7b2..16a560c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Changelog for the [`ghc-typelits-knownnat`](http://hackage.haskell.org/package/ghc-typelits-knownnat) package +## 0.7.6 *June 18th 2021* +* Add support for GHC 9.2.0.20210422 + ## 0.7.5 *February 10th 2021* * Raise upper limit for TH dep to allow building on ghc-9.0.1 diff --git a/ghc-typelits-knownnat.cabal b/ghc-typelits-knownnat.cabal index 8a58cf3..0be8505 100644 --- a/ghc-typelits-knownnat.cabal +++ b/ghc-typelits-knownnat.cabal @@ -1,5 +1,5 @@ name: ghc-typelits-knownnat -version: 0.7.5 +version: 0.7.6 synopsis: Derive KnownNat constraints from other KnownNat constraints description: A type checker plugin for GHC that can derive \"complex\" @KnownNat@ @@ -54,7 +54,7 @@ extra-source-files: README.md 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.4, GHC == 9.0.1 + GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1, GHC == 9.2.1 source-repository head type: git @@ -86,12 +86,12 @@ library UndecidableInstances ViewPatterns build-depends: base >= 4.9 && <5, - ghc >= 8.0.1 && <9.2, - ghc-prim >= 0.4.0.0 && <0.8, + ghc >= 8.0.1 && <9.4, + ghc-prim >= 0.4.0.0 && <0.9, ghc-tcplugins-extra >= 0.3.1, ghc-typelits-natnormalise >= 0.7.1 && <0.8, transformers >= 0.5.2.0 && <0.6, - template-haskell >= 2.11.0.0 && <2.18 + template-haskell >= 2.11.0.0 && <2.19 hs-source-dirs: src default-language: Haskell2010 if flag(deverror) diff --git a/src/GHC/TypeLits/KnownNat.hs b/src/GHC/TypeLits/KnownNat.hs index c3e7369..ae5f1d7 100644 --- a/src/GHC/TypeLits/KnownNat.hs +++ b/src/GHC/TypeLits/KnownNat.hs @@ -154,6 +154,9 @@ import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), type (*), type (^), type (-), type (<=?), type (<=), natVal) #endif +#if MIN_VERSION_base(4,16,0) +import Data.Type.Ord (OrdCond) +#endif import GHC.TypeLits.KnownNat.TH @@ -287,6 +290,12 @@ instance (KnownNat a, KnownNat b) => KnownBoolNat2 $(nameToSymbol ''(<=?)) a b w boolNatSing2 = SBoolKb (natVal (Proxy @a) <= natVal (Proxy @b)) {-# INLINE boolNatSing2 #-} +#if MIN_VERSION_base(4,16,0) +instance (KnownNat a, KnownNat b) => KnownBoolNat2 $(nameToSymbol ''OrdCond) a b where + boolNatSing2 = SBoolKb (natVal (Proxy @a) <= natVal (Proxy @b)) + {-# INLINE boolNatSing2 #-} +#endif + -- | Class for ternary functions with a Natural result. -- -- The 'Symbol' /f/ must correspond to the fully qualified name of the diff --git a/src/GHC/TypeLits/KnownNat/Solver.hs b/src/GHC/TypeLits/KnownNat/Solver.hs index 0a981e1..e07c2e8 100644 --- a/src/GHC/TypeLits/KnownNat/Solver.hs +++ b/src/GHC/TypeLits/KnownNat/Solver.hs @@ -115,6 +115,10 @@ import GHC.TypeLits.Normalise.Unify (CType (..),normaliseNat,reifySOP) import GHC.Builtin.Names (knownNatClassName) import GHC.Builtin.Types (boolTy) import GHC.Builtin.Types.Literals (typeNatAddTyCon, typeNatDivTyCon, typeNatSubTyCon) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Builtin.Types (promotedFalseDataCon, promotedTrueDataCon) +import GHC.Builtin.Types.Literals (typeNatCmpTyCon) +#endif import GHC.Core.Class (Class, classMethods, className, classTyCon) import GHC.Core.Coercion (Role (Representational), mkUnivCo) import GHC.Core.InstEnv (instanceDFunId, lookupUniqueInstEnv) @@ -449,6 +453,20 @@ constraintToEvTerm defs givens (ct,cls,op,orig) = do () | Just knN_cls <- knownNatN defs (length args0) , Right (inst, _) <- lookupUniqueInstEnv ienv knN_cls args1 -> Just (inst,knN_cls,args0,args1) +#if MIN_VERSION_base(4,16,0) + | fn0 == "Data.Type.Ord.OrdCond" + , [_,cmpNat,TyConApp t1 [],TyConApp t2 [],TyConApp f1 []] <- args0 + , TyConApp cmpNatTc args2 <- cmpNat + , cmpNatTc == typeNatCmpTyCon + , t1 == promotedTrueDataCon + , t2 == promotedTrueDataCon + , f1 == promotedFalseDataCon + , let knN_cls = knownBoolNat2 defs + ki = typeKind (head args2) + args1N = ki:fn1:args2 + , Right (inst,_) <- lookupUniqueInstEnv ienv knN_cls args1N + -> Just (inst,knN_cls,args2,args1N) +#endif | length args0 == 2 , let knN_cls = knownBoolNat2 defs ki = typeKind (head args0) @@ -697,12 +715,12 @@ makeOpDict (opCls,dfid) knCls tyArgsC tyArgsI z evArgs , Just (_, op_co_rep) <- tcInstNewTyCon_maybe op_tcRep op_args -- SNatKn (a+b) ~ Integer #if MIN_VERSION_ghc(8,5,0) - , let EvExpr dfun_inst = evDFunApp dfid tyArgsI evArgs + , EvExpr dfun_inst <- evDFunApp dfid tyArgsI evArgs #else , let dfun_inst = EvDFunApp dfid tyArgsI evArgs #endif -- KnownNatAdd a b - op_to_kn = mkTcTransCo (mkTcTransCo op_co_dict op_co_rep) + , let op_to_kn = mkTcTransCo (mkTcTransCo op_co_dict op_co_rep) (mkTcSymCo (mkTcTransCo kn_co_dict kn_co_rep)) -- KnownNatAdd a b ~ KnownNat (a+b) ev_tm = mkEvCast dfun_inst op_to_kn