From 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 29 Mar 2021 20:51:46 +0800 Subject: [PATCH] Add support for GHC-9.0.1 --- .../dependent-sum-template.cabal | 6 ++++-- .../src/Data/Dependent/Sum/TH/Internal.hs | 18 +++++++++++++----- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/dependent-sum-template/dependent-sum-template.cabal b/dependent-sum-template/dependent-sum-template.cabal index 1d2d17f..4b7f1c7 100644 --- a/dependent-sum-template/dependent-sum-template.cabal +++ b/dependent-sum-template/dependent-sum-template.cabal @@ -18,7 +18,8 @@ tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.3 + GHC == 8.8.3, + GHC == 9.0.1 extra-source-files: ChangeLog.md @@ -36,7 +37,8 @@ Library build-depends: base >= 3 && <5, dependent-sum >= 0.4.1 && < 0.8, template-haskell, - th-extras >= 0.0.0.2 + th-extras >= 0.0.0.2, + th-abstraction test-suite test if impl(ghc < 8.0) diff --git a/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs b/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs index 0bf5afd..16ed953 100644 --- a/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs +++ b/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs @@ -10,6 +10,7 @@ module Data.Dependent.Sum.TH.Internal where import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Extras +import Language.Haskell.TH.Datatype.TyVarBndr classHeadToParams :: Type -> (Name, [Type]) classHeadToParams t = (h, reverse reversedParams) @@ -24,8 +25,11 @@ classHeadToParams t = (h, reverse reversedParams) -- Invoke the deriver for the given class instance. We assume that the type -- we're deriving for is always the first typeclass parameter, if there are -- multiple. -deriveForDec :: Name -> (Q Type -> Q Type) -> ([TyVarBndr] -> [Con] -> Q Dec) -> Dec -> Q [Dec] -deriveForDec className _ f (InstanceD overlaps cxt classHead decs) = do +deriveForDec :: Name -> (Q Type -> Q Type) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec] +deriveForDec className makeClassHead f dec = deriveForDec' className makeClassHead (f . changeTVFlags specifiedSpec) dec + +deriveForDec' :: Name -> (Q Type -> Q Type) -> ([TyVarBndrUnit] -> [Con] -> Q Dec) -> Dec -> Q [Dec] +deriveForDec' className _ f (InstanceD overlaps cxt classHead decs) = do let (givenClassName, firstParam : _) = classHeadToParams classHead when (givenClassName /= className) $ fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName @@ -36,20 +40,24 @@ deriveForDec className _ f (InstanceD overlaps cxt classHead decs) = do dec <- f bndrs cons return [InstanceD overlaps cxt classHead [dec]] _ -> fail $ "while deriving " ++ show className ++ ": the name of an algebraic data type constructor is required" -deriveForDec className makeClassHead f (DataD dataCxt name bndrs _ cons _) = return <$> inst +deriveForDec' className makeClassHead f (DataD dataCxt name bndrs _ cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (makeClassHead $ conT name) [dec] dec = f bndrs cons #if __GLASGOW_HASKELL__ >= 808 -deriveForDec className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst +deriveForDec' className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst #else -deriveForDec className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst +deriveForDec' className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst #endif where inst = instanceD (cxt (map return dataCxt)) clhead [dec] #if __GLASGOW_HASKELL__ >= 808 clhead = makeClassHead $ return $ initTy ty +#if __GLASGOW_HASKELL__ >= 900 + bndrs = [PlainTV v x | PlainTV v x <- maybe [] id tvBndrs] +#else bndrs = [PlainTV v | PlainTV v <- maybe [] id tvBndrs] +#endif initTy (AppT ty _) = ty #else clhead = makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs))