Support GHC 9.2. (#436)

* Support GHC 9.2. Widens template-haskell bounds and removes `mappend` definitions in favor of defaulting to `<>`, as per `-Wnoncanonical-monoid-instances`. * Add 9.2.1 to CI builders. * Prevent no-implementation errors on GHC 8.2 and earlier. * Use Semigroup.<> for this definition. * Include the standard mappend definition in Summary, too. * Ensure we always have a Semigroup constraint across versions. * GHC 8.0 couldn't deduce those type implications, so an #ifdef it is. * One further ifdef for the import. * Squash -wno-star-is-type errors. * One last squashing. * Fix partial pattern match.
hedgehogqa · Dec 27, 2021 · 21a5131 · 21a5131
1 parent f8247c1
commit 21a5131
Show file tree

Hide file tree

Showing 8 changed files with 32 additions and 15 deletions.
diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml
@@ -14,7 +14,7 @@ jobs:
       matrix:
         os:    [macos-latest, ubuntu-latest, windows-latest]
         cabal: ["3.4"]
-        ghc:   ["8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7"]
+        ghc:   ["8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.2.1"]
 
     runs-on: ${{ matrix.os }}
 

diff --git a/hedgehog-example/hedgehog-example.cabal b/hedgehog-example/hedgehog-example.cabal
@@ -66,7 +66,7 @@ library
     , process                         >= 1.2        && < 1.7
     , QuickCheck                      >= 2.7        && < 2.15
     , resourcet                       >= 1.1        && < 1.3
-    , template-haskell                >= 2.10       && < 2.17
+    , template-haskell                >= 2.10       && < 2.19
     , temporary                       >= 1.3        && < 1.4
     , temporary-resourcet             >= 0.1        && < 0.2
     , text                            >= 1.1        && < 1.3

diff --git a/hedgehog-example/src/Test/Example/References.hs b/hedgehog-example/src/Test/Example/References.hs
@@ -13,6 +13,7 @@ import           Data.Bifunctor (second)
 import           Data.IORef (IORef)
 import qualified Data.IORef as IORef
 import qualified Data.List as List
+import           Data.Kind (Type)
 
 import           Hedgehog
 import qualified Hedgehog.Gen as Gen
@@ -34,7 +35,7 @@ initialState =
 ------------------------------------------------------------------------
 -- NewRef
 
-data NewRef (v :: * -> *) =
+data NewRef (v :: Type -> Type) =
   NewRef
   deriving (Eq, Show, Generic)
 

diff --git a/hedgehog-example/src/Test/Example/Registry.hs b/hedgehog-example/src/Test/Example/Registry.hs
@@ -13,6 +13,7 @@ import           GHC.Generics (Generic)
 
 import           Data.Foldable (traverse_)
 import qualified Data.HashTable.IO as HashTable
+import           Data.Kind (Type)
 import           Data.IORef (IORef)
 import qualified Data.IORef as IORef
 import           Data.Map (Map)
@@ -67,7 +68,7 @@ initialState =
 --   S#state{pids=S#state.pids++[Pid]}.
 --
 
-data Spawn (v :: * -> *) =
+data Spawn (v :: Type -> Type) =
   Spawn
   deriving (Eq, Show, Generic)
 
@@ -177,7 +178,7 @@ register =
 --   S#state{regs=lists:keydelete(Name,1,S#state.regs)}.
 --
 
-data Unregister (v :: * -> *) =
+data Unregister (v :: Type -> Type) =
   Unregister Name
   deriving (Eq, Show, Generic)
 

diff --git a/hedgehog-example/src/Test/Example/Resource.hs b/hedgehog-example/src/Test/Example/Resource.hs
@@ -171,8 +171,11 @@ joinBlocks = \case
     []
   xs0 ->
     let
-      (xs, x : ys) =
-        List.span (/= "}") xs0
+      (xs, body) = List.span (/= "}") xs0
+      (x, ys) = case body of
+        (x' : y') -> (x', y')
+        _ -> error "joinBlocks: expected closing brace"
+
     in
       concat (List.intersperse "\n" (xs ++ [x])) : joinBlocks ys
 

diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal
@@ -39,6 +39,7 @@ tested-with:
   , GHC == 8.6.5
   , GHC == 8.8.3
   , GHC == 8.10.1
+  , GHC == 9.2.1
 extra-source-files:
   README.md
   CHANGELOG.md
@@ -70,7 +71,7 @@ library
     , random                          >= 1.1        && < 1.3
     , resourcet                       >= 1.1        && < 1.3
     , stm                             >= 2.4        && < 2.6
-    , template-haskell                >= 2.10       && < 2.18
+    , template-haskell                >= 2.10       && < 2.19
     , text                            >= 1.1        && < 1.3
     , time                            >= 1.4        && < 1.13
     , transformers                    >= 0.5        && < 0.6

diff --git a/hedgehog/src/Hedgehog/Internal/Gen.hs b/hedgehog/src/Hedgehog/Internal/Gen.hs
@@ -471,9 +471,15 @@ instance (Monad m, Semigroup a) => Semigroup (GenT m a) where
   (<>) =
     liftA2 (Semigroup.<>)
 
-instance (Monad m, Monoid a) => Monoid (GenT m a) where
-  mappend =
-    liftA2 mappend
+instance (
+  Monad m, Monoid a
+#if !MIN_VERSION_base(4,11,0)
+  , Semigroup a
+#endif
+         ) => Monoid (GenT m a) where
+#if !MIN_VERSION_base(4,11,0)
+  mappend = (Semigroup.<>)
+#endif
 
   mempty =
     return mempty

diff --git a/hedgehog/src/Hedgehog/Internal/Report.hs b/hedgehog/src/Hedgehog/Internal/Report.hs
@@ -46,6 +46,9 @@ import qualified Data.List as List
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe (mapMaybe, catMaybes)
+#if !MIN_VERSION_base(4,11,0)
+import qualified Data.Semigroup as Semigroup
+#endif
 import           Data.Traversable (for)
 
 import           Hedgehog.Internal.Config
@@ -140,19 +143,21 @@ data Summary =
     } deriving (Show)
 
 instance Monoid Summary where
+#if !MIN_VERSION_base(4,11,0)
+  mappend = (Semigroup.<>)
+#endif
   mempty =
     Summary 0 0 0 0 0
-  mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) =
+
+instance Semigroup Summary where
+  Summary x1 x2 x3 x4 x5 <> Summary y1 y2 y3 y4 y5 =
     Summary
       (x1 + y1)
       (x2 + y2)
       (x3 + y3)
       (x4 + y4)
       (x5 + y5)
 
-instance Semigroup Summary where
-  (<>) = mappend
-
 -- | Construct a summary from a single result.
 --
 fromResult :: Result -> Summary