Add support for GHC 9.2.0.20210422

clash-lang · Jun 18, 2021 · fb94131 · fb94131
1 parent ef034b9
commit fb94131
Show file tree

Hide file tree

Showing 5 changed files with 41 additions and 7 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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