Support building with template-haskell-2.21.*, th-abstraction-0.6.*

CHANGELOG.md

@@ -1,4 +1,5 @@
 ### next [????.??.??]
+* Support building with `template-haskell-2.21.*` (GHC 9.8).
 * The Template Haskell machinery now uses `TemplateHaskellQuotes` when building
   with GHC 8.0+ instead of manually constructing each Template Haskell `Name`.
   A consequence of this is that `deriving-compat` will now build with GHC 9.8,

deriving-compat.cabal

@@ -141,16 +141,17 @@ library
                        Text.Show.Deriving.Internal
   build-depends:       containers          >= 0.1   && < 0.7
                      , ghc-prim
-                     , th-abstraction      >= 0.4   && < 0.6
+                     , th-abstraction      >= 0.4   && < 0.7
 
   if flag(base-4-9)
     build-depends:     base                >= 4.9   && < 5
     cpp-options:       "-DNEW_FUNCTOR_CLASSES"
   else
     build-depends:     base                >= 4.3   && < 4.9
+                     , semigroups          >= 0.6   && < 0.21
 
   if flag(template-haskell-2-11)
-    build-depends:     template-haskell    >= 2.11  && < 2.21
+    build-depends:     template-haskell    >= 2.11  && < 2.22
                      , ghc-boot-th
   else
     build-depends:     template-haskell    >= 2.5   && < 2.11
@@ -189,7 +190,7 @@ test-suite spec
                      , hspec               >= 1.8
                      , QuickCheck          >= 2      && < 3
                      , tagged              >= 0.7    && < 1
-                     , template-haskell    >= 2.5    && < 2.21
+                     , template-haskell    >= 2.5    && < 2.22
                      , void                >= 0.5.10 && < 1
   build-tool-depends:  hspec-discover:hspec-discover >= 1.8
 

src/Data/Bounded/Deriving/Internal.hs

@@ -20,6 +20,8 @@ module Data.Bounded.Deriving.Internal (
     ) where
 
 import Data.Deriving.Internal
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
 
 import Language.Haskell.TH.Datatype
 import Language.Haskell.TH.Lib
@@ -90,7 +92,7 @@ makeBoundedFun bf name = do
 -- given constructors. All constructors must be from the same type.
 makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
 makeBoundedFunForCons _  _      [] = noConstructorsError
-makeBoundedFunForCons bf tyName cons
+makeBoundedFunForCons bf tyName (con:cons')
     | not (isProduct || isEnumeration)
     = enumerationOrProductError $ nameBase tyName
     | isEnumeration
@@ -102,9 +104,12 @@ makeBoundedFunForCons bf tyName cons
     isProduct     = isProductType cons
     isEnumeration = isEnumerationType cons
 
+    cons :: NonEmpty ConstructorInfo
+    cons = con :| cons'
+
     con1, conN :: Q Exp
-    con1 = conE $ constructorName $ head cons
-    conN = conE $ constructorName $ last cons
+    con1 = conE $ constructorName con
+    conN = conE $ constructorName $ NE.last cons
 
     pickCon :: Q Exp
     pickCon = case bf of
@@ -114,7 +119,7 @@ makeBoundedFunForCons bf tyName cons
     pickConApp :: Q Exp
     pickConApp = appsE
                $ pickCon
-               : map varE (replicate (conArity $ head cons) (boundedFunName bf))
+               : map varE (replicate (conArity con) (boundedFunName bf))
 
 -------------------------------------------------------------------------------
 -- Class-specific constants

src/Data/Deriving/Internal.hs

@@ -42,6 +42,7 @@ import           Data.Functor.Classes
                    )
 #endif
 import qualified Data.List as List
+import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Map as Map
 import           Data.Map (Map)
 import           Data.Maybe
@@ -824,15 +825,14 @@ conArity :: ConstructorInfo -> Int
 conArity (ConstructorInfo { constructorFields = tys }) = length tys
 
 -- | Returns 'True' if it's a datatype with exactly one, non-existential constructor.
-isProductType :: [ConstructorInfo] -> Bool
-isProductType [con] = null (constructorVars con)
-isProductType _     = False
+isProductType :: NonEmpty ConstructorInfo -> Bool
+isProductType (con :| []) = null (constructorVars con)
+isProductType _           = False
 
 -- | Returns 'True' if it's a datatype with one or more nullary, non-GADT
 -- constructors.
-isEnumerationType :: [ConstructorInfo] -> Bool
-isEnumerationType cons@(_:_) = all (App.liftA2 (&&) isNullaryCon isVanillaCon) cons
-isEnumerationType _          = False
+isEnumerationType :: NonEmpty ConstructorInfo -> Bool
+isEnumerationType cons = F.all (App.liftA2 (&&) isNullaryCon isVanillaCon) cons
 
 -- | Returns 'False' if we're dealing with existential quantification or GADTs.
 isVanillaCon :: ConstructorInfo -> Bool

src/Data/Deriving/Via/Internal.hs

@@ -148,7 +148,7 @@ deriveViaDecs instanceTy mbViaTy = do
         _ -> fail $ "Not a type class: " ++ pprint clsTy
     _ -> fail $ "Malformed instance: " ++ pprint instanceTy
 
-deriveViaDecs' :: Name -> [TyVarBndrUnit] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])
+deriveViaDecs' :: Name -> [TyVarBndr_ flag] -> [Type] -> Type -> Dec -> Q (Maybe [Dec])
 deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do
     let numExpectedArgs = length clsTvbs
         numActualArgs   = length clsArgs
@@ -187,7 +187,7 @@ deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do
 
     go _ = return Nothing
 
-mkCoerceClassMethEqn :: [TyVarBndrUnit] -> [Type] -> Type -> Type -> (Type, Type)
+mkCoerceClassMethEqn :: [TyVarBndr_ flag] -> [Type] -> Type -> Type -> (Type, Type)
 mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy
   = ( applySubstitution rhsSubst methTy
     , applySubstitution lhsSubst methTy

src/Data/Enum/Deriving/Internal.hs

@@ -22,6 +22,7 @@ module Data.Enum.Deriving.Internal (
     ) where
 
 import Data.Deriving.Internal
+import Data.List.NonEmpty (NonEmpty(..))
 
 import Language.Haskell.TH.Datatype
 import Language.Haskell.TH.Lib
@@ -116,7 +117,7 @@ makeEnumFun ef name = do
 -- given constructors. All constructors must be from the same type.
 makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
 makeEnumFunForCons _  _      _  [] = noConstructorsError
-makeEnumFunForCons ef tyName ty cons
+makeEnumFunForCons ef tyName ty (con:cons')
     | not $ isEnumerationType cons
     = enumerationError tyNameBase
     | otherwise = case ef of
@@ -173,8 +174,11 @@ makeEnumFunForCons ef tyName ty cons
     tyNameBase :: String
     tyNameBase = nameBase tyName
 
+    cons :: NonEmpty ConstructorInfo
+    cons = con :| cons'
+
     maxTagExpr :: Q Exp
-    maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName
+    maxTagExpr = integerE (length cons') `sigE` conT intTypeName
 
     lamOne :: (Name -> Q Exp) -> Q Exp
     lamOne f = do

src/Data/Ix/Deriving/Internal.hs

@@ -19,6 +19,7 @@ module Data.Ix.Deriving.Internal (
     ) where
 
 import Data.Deriving.Internal
+import Data.List.NonEmpty (NonEmpty(..))
 
 import Language.Haskell.TH.Datatype
 import Language.Haskell.TH.Lib
@@ -95,7 +96,7 @@ makeIxFun ixf name = do
 -- given constructors. All constructors must be from the same type.
 makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
 makeIxFunForCons _   _      _  [] = noConstructorsError
-makeIxFunForCons ixf tyName ty cons
+makeIxFunForCons ixf tyName ty (con:cons')
     | not (isProduct || isEnumeration)
     = enumerationOrProductError $ nameBase tyName
     | isEnumeration
@@ -144,10 +145,7 @@ makeIxFunForCons ixf tyName ty cons
                     ]
 
     | otherwise -- It's a product type
-    = do let con :: ConstructorInfo
-             con = head cons
-
-             conName :: Name
+    = do let conName :: Name
              conName = constructorName con
 
              conFields :: Int
@@ -204,6 +202,9 @@ makeIxFunForCons ixf tyName ty cons
                mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b]
                                                      `appE` varE c
   where
+    cons :: NonEmpty ConstructorInfo
+    cons = con :| cons'
+
     isProduct, isEnumeration :: Bool
     isProduct     = isProductType cons
     isEnumeration = isEnumerationType cons

src/Data/Ord/Deriving/Internal.hs

@@ -39,6 +39,8 @@ module Data.Ord.Deriving.Internal (
 
 import           Data.Deriving.Internal
 import           Data.List (partition)
+import qualified Data.List.NonEmpty as NE
+import           Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.Map as Map
 import           Data.Map (Map)
 
@@ -277,10 +279,6 @@ makeOrdFunForCons oFun instTypes cons = do
         singleConType :: Bool
         singleConType = isSingleton cons
 
-        firstConName, lastConName :: Name
-        firstConName = constructorName $ head cons
-        lastConName  = constructorName $ last cons
-
         -- Alternatively, we could look these up from dataConTagMap, but this
         -- is slightly faster due to the lack of Map lookups.
         firstTag, lastTag :: Int
@@ -290,22 +288,30 @@ makeOrdFunForCons oFun instTypes cons = do
         dataConTagMap :: Map Name Int
         dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..]
 
-        ordMatches :: ConstructorInfo -> Q Match
-        ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType
-                                      firstTag firstConName lastTag lastConName
-                                      dataConTagMap
-
         ordFunRhs :: Q Exp
-        ordFunRhs
-          | null cons
-          = conE eqDataName
+        ordFunRhs =
+          case cons of
+            [] -> conE eqDataName
+            c:cs -> ordFunRhsNonEmptyCons (c :| cs)
+
+        ordFunRhsNonEmptyCons :: NonEmpty ConstructorInfo -> Q Exp
+        ordFunRhsNonEmptyCons cs@(c :| _)
           | length nullaryCons <= 2
-          = caseE (varE v1) $ map ordMatches cons
+          = caseE (varE v1) $ map ordMatches $ NE.toList cs
           | null nonNullaryCons
           = mkTagCmp
           | otherwise
           = caseE (varE v1) $ map ordMatches nonNullaryCons
                 ++ [match wildP (normalB mkTagCmp) []]
+          where
+            firstConName, lastConName :: Name
+            firstConName = constructorName c
+            lastConName  = constructorName $ NE.last cs
+
+            ordMatches :: ConstructorInfo -> Q Match
+            ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType
+                                          firstTag firstConName lastTag lastConName
+                                          dataConTagMap
 
         mkTagCmp :: Q Exp
         mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $