Add support for GHC-9.0.1

obsidiansystems · Mar 29, 2021 · 8cf4c7f · 8cf4c7f
1 parent 6e77767
commit 8cf4c7f
Show file tree

Hide file tree

Showing 2 changed files with 17 additions and 7 deletions.
diff --git 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
@@ -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))