ghc-typelits-extra 0.4.2 → 0.4.3
raw patch · 6 files changed
+89/−11 lines, 6 filesdep ~ghcdep ~ghc-bignumPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc, ghc-bignum
API changes (from Hackage documentation)
Files
- CHANGELOG.md +3/−0
- README.md +1/−1
- ghc-typelits-extra.cabal +3/−3
- src/GHC/TypeLits/Extra/Solver.hs +63/−7
- src/GHC/TypeLits/Extra/Solver/Operations.hs +1/−0
- tests/ErrorTests.hs +18/−0
CHANGELOG.md view
@@ -1,5 +1,8 @@ # Changelog for the [`ghc-typelits-extra`](http://hackage.haskell.org/package/ghc-typelits-extra) package +# 0.4.3 *June 18th 2021*+* Add support for GHC 9.2.0.20210422+ # 0.4.2 *January 1st 2021* * Add support for GHC 9.0.1-rc1
README.md view
@@ -1,6 +1,6 @@ # ghc-typelits-extra -[](http://travis-ci.org/clash-lang/ghc-typelits-extra)+[](https://github.com/clash-lang/ghc-typelits-extra/actions) [](https://hackage.haskell.org/package/ghc-typelits-extra) [](http://packdeps.haskellers.com/feed?needle=exact%3Aghc-typelits-extra)
ghc-typelits-extra.cabal view
@@ -1,5 +1,5 @@ name: ghc-typelits-extra-version: 0.4.2+version: 0.4.3 synopsis: Additional type-level operations on GHC.TypeLits.Nat description: Additional type-level operations on @GHC.TypeLits.Nat@:@@ -48,7 +48,7 @@ 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.3, GHC == 9.0.1+ GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1, GHC == 9.2.1 source-repository head@@ -68,7 +68,7 @@ GHC.TypeLits.Extra.Solver.Operations build-depends: base >= 4.8 && <5, containers >= 0.5.7.1 && <0.7,- ghc >= 7.10 && <9.2,+ ghc >= 7.10 && <9.4, ghc-prim >= 0.5 && <1.0, ghc-tcplugins-extra >= 0.3.1, ghc-typelits-knownnat >= 0.7.2 && <0.8,
src/GHC/TypeLits/Extra/Solver.hs view
@@ -36,8 +36,18 @@ -- GHC API #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqPrimTyConKey, hasKey)-import GHC.Builtin.Types (typeNatKind, promotedTrueDataCon, promotedFalseDataCon)-import GHC.Builtin.Types.Literals (typeNatLeqTyCon, typeNatTyCons)+import GHC.Builtin.Types (promotedTrueDataCon, promotedFalseDataCon)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Builtin.Types (boolTy, naturalTy)+#else+import GHC.Builtin.Types (typeNatKind)+#endif+import GHC.Builtin.Types.Literals (typeNatTyCons)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Builtin.Types.Literals (typeNatCmpTyCon)+#else+import GHC.Builtin.Types.Literals (typeNatLeqTyCon)+#endif import GHC.Core.Predicate (EqRel (NomEq), Pred (EqPred), classifyPredType) import GHC.Core.TyCo.Rep (Type (..)) import GHC.Core.Type (Kind, eqType, mkTyConApp, splitTyConApp_maybe, typeKind)@@ -47,6 +57,9 @@ import GHC.Tc.Types (TcPlugin(..), TcPluginResult (..)) import GHC.Tc.Types.Constraint (Ct, ctEvidence, ctEvPred, ctLoc, isWantedCt, cc_ev)+#if MIN_VERSION_ghc(9,2,0)+import GHC.Tc.Types.Constraint (Ct (CQuantCan), qci_ev)+#endif import GHC.Tc.Types.Evidence (EvTerm) import GHC.Types.Name.Occurrence (mkTcOcc) import GHC.Unit.Module (mkModuleName)@@ -89,6 +102,11 @@ import GHC.TypeLits.Extra.Solver.Operations import GHC.TypeLits.Extra.Solver.Unify +#if MIN_VERSION_ghc(9,2,0)+typeNatKind :: Type+typeNatKind = naturalTy+#endif+ -- | A solver implement as a type-checker plugin for: -- -- * 'Div': type-level 'div'@@ -227,8 +245,18 @@ (t1', n1) <- normaliseNat defs t1 (t2', n2) <- normaliseNat defs t2 pure (NatEquality ct t1' t2' (mergeNormalised n1 n2))+#if MIN_VERSION_ghc(9,2,0)+ | TyConApp tc [_,cmpNat,TyConApp tt1 [],TyConApp tt2 [],TyConApp ff1 []] <- t1+ , tc == ordTyCon defs+ , TyConApp cmpNatTc [x,y] <- cmpNat+ , cmpNatTc == typeNatCmpTyCon+ , tt1 == promotedTrueDataCon+ , tt2 == promotedTrueDataCon+ , ff1 == promotedFalseDataCon+#else | TyConApp tc [x,y] <- t1 , tc == typeNatLeqTyCon+#endif , TyConApp tc' [] <- t2 -> do (x', n1) <- normaliseNat defs x@@ -245,16 +273,32 @@ createWantedFromNormalised :: ExtraDefs -> SolverConstraint -> TcPluginM Ct createWantedFromNormalised defs sct = do let extractCtSides (NatEquality ct t1 t2 _) = (ct, reifyEOP defs t1, reifyEOP defs t2)- extractCtSides (NatInequality ct x y b _) = let tc = if b then promotedTrueDataCon else promotedFalseDataCon- t1 = TyConApp typeNatLeqTyCon [reifyEOP defs x, reifyEOP defs y]- t2 = TyConApp tc []- in (ct, t1, t2)+ extractCtSides (NatInequality ct x y b _) =+ let tc = if b then promotedTrueDataCon else promotedFalseDataCon+#if MIN_VERSION_ghc(9,2,0)+ t1 = TyConApp (ordTyCon defs)+ [ boolTy+ , TyConApp typeNatCmpTyCon [reifyEOP defs x, reifyEOP defs y]+ , TyConApp promotedTrueDataCon []+ , TyConApp promotedTrueDataCon []+ , TyConApp promotedFalseDataCon []+ ]+#else+ t1 = TyConApp typeNatLeqTyCon [reifyEOP defs x, reifyEOP defs y]+#endif+ t2 = TyConApp tc []+ in (ct, t1, t2) let (ct, t1, t2) = extractCtSides sct newPredTy <- case splitTyConApp_maybe $ ctEvPred $ ctEvidence ct of Just (tc, [a, b, _, _]) | tc `hasKey` eqPrimTyConKey -> pure (mkTyConApp tc [a, b, t1, t2]) _ -> fail "Nothing" ev <- newWanted (ctLoc ct) newPredTy- return (ct { cc_ev = ev })+ let ctN = case ct of+#if MIN_VERSION_ghc(9,2,0)+ CQuantCan qc -> CQuantCan (qc { qci_ev = ev})+#endif+ ctX -> ctX { cc_ev = ev }+ return ctN fromSolverConstraint :: SolverConstraint -> Ct fromSolverConstraint (NatEquality ct _ _ _) = ct@@ -263,6 +307,9 @@ lookupExtraDefs :: TcPluginM ExtraDefs lookupExtraDefs = do md <- lookupModule myModule myPackage+#if MIN_VERSION_ghc(9,2,0)+ md2 <- lookupModule ordModule basePackage+#endif ExtraDefs <$> look md "Max" <*> look md "Min" #if MIN_VERSION_ghc(8,4,0)@@ -277,10 +324,19 @@ <*> look md "Log" <*> look md "GCD" <*> look md "LCM"+#if MIN_VERSION_ghc(9,2,0)+ <*> look md2 "OrdCond"+#else+ <*> pure typeNatLeqTyCon+#endif where look md s = tcLookupTyCon =<< lookupName md (mkTcOcc s) myModule = mkModuleName "GHC.TypeLits.Extra" myPackage = fsLit "ghc-typelits-extra"+#if MIN_VERSION_ghc(9,2,0)+ ordModule = mkModuleName "Data.Type.Ord"+ basePackage = fsLit "base"+#endif -- Utils evMagic :: Ct -> Maybe EvTerm
src/GHC/TypeLits/Extra/Solver/Operations.hs view
@@ -110,6 +110,7 @@ , logTyCon :: TyCon , gcdTyCon :: TyCon , lcmTyCon :: TyCon+ , ordTyCon :: TyCon } reifyEOP :: ExtraDefs -> ExtraOp -> Type
tests/ErrorTests.hs view
@@ -308,7 +308,13 @@ ["Couldn't match type ‘'False’ with ‘'True’"] testFail11Errors =+#if __GLASGOW_HASKELL__ >= 902+ ["Couldn't match type ‘Data.Type.Ord.OrdCond"+ ,"(CmpNat (CLog 2 4) (CLog 4 4)) 'True 'True 'False’"+ ,"with ‘'True’"]+#else ["Couldn't match type ‘CLog 2 4 <=? CLog 4 4’ with ‘'True’"]+#endif testFail23Errors = #if __GLASGOW_HASKELL__ >= 804@@ -318,10 +324,22 @@ #endif testFail24Errors =+#if __GLASGOW_HASKELL__ >= 902+ ["Couldn't match type ‘Data.Type.Ord.OrdCond"+ ,"(CmpNat z (Max x y)) 'True 'True 'False’"+ ,"with ‘'True’"]+#else ["Couldn't match type ‘z <=? Max x y’ with ‘'True’"]+#endif testFail25Errors =+#if __GLASGOW_HASKELL__ >= 902+ ["Couldn't match type ‘Data.Type.Ord.OrdCond"+ ,"(CmpNat (x + 1) (Max x y)) 'True 'True 'False’"+ ,"with ‘'True’"]+#else ["Couldn't match type ‘(x + 1) <=? Max x y’ with ‘'True’"]+#endif testFail26Errors = ["Could not deduce: Max x y ~ n"