GHC 9 Support

hedgehog/hedgehog.cabal

@@ -71,7 +71,7 @@ library
     , resourcet                       >= 1.1        && < 1.3
     , semigroups                      >= 0.16       && < 0.20
     , stm                             >= 2.4        && < 2.6
-    , template-haskell                >= 2.10       && < 2.17
+    , template-haskell                >= 2.10       && < 2.18
     , text                            >= 1.1        && < 1.3
     , time                            >= 1.4        && < 1.10
     , transformers                    >= 0.5        && < 0.6

hedgehog/src/Hedgehog/Internal/Distributive.hs

@@ -22,16 +22,17 @@ import qualified Control.Monad.Trans.State.Strict as Strict
 import qualified Control.Monad.Trans.Writer.Lazy as Lazy
 import qualified Control.Monad.Trans.Writer.Strict as Strict
 
+import           Data.Kind (Type)
 import           GHC.Exts (Constraint)
 
 ------------------------------------------------------------------------
 -- * MonadTransDistributive
 
 class MonadTransDistributive g where
   type Transformer
-    (f :: (* -> *) -> * -> *)
-    (g :: (* -> *) -> * -> *)
-    (m :: * -> *) :: Constraint
+    (f :: (Type -> Type) -> Type -> Type)
+    (g :: (Type -> Type) -> Type -> Type)
+    (m :: Type -> Type) :: Constraint
 
   type Transformer f g m = (
       Monad m

hedgehog/src/Hedgehog/Internal/Gen.hs

@@ -204,6 +204,7 @@ import qualified Data.Char as Char
 import           Data.Foldable (for_, toList)
 import           Data.Functor.Identity (Identity(..))
 import           Data.Int (Int8, Int16, Int32, Int64)
+import           Data.Kind (Type)
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map (Map)
@@ -350,7 +351,7 @@ generalize =
 -- | Class of monads which can generate input data for tests.
 --
 class (Monad m, Monad (GenBase m)) => MonadGen m where
-  type GenBase m :: (* -> *)
+  type GenBase m :: (Type -> Type)
 
   -- | Extract a 'GenT' from a  'MonadGen'.
   --

hedgehog/src/Hedgehog/Internal/State.hs

@@ -65,6 +65,7 @@ import           Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep)
 import           Data.Foldable (traverse_)
 import           Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..))
 import           Data.Functor.Classes (eq1, compare1, showsPrec1)
+import           Data.Kind (Type)
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Maybe as Maybe
@@ -374,7 +375,7 @@ callbackEnsure callbacks s0 s i o =
 -- an instance of 'MonadTest'. These constraints appear when you pass
 -- your 'Command' list to 'sequential' or 'parallel'.
 --
-data Command gen m (state :: (* -> *) -> *) =
+data Command gen m (state :: (Type -> Type) -> Type) =
   forall input output.
   (HTraversable input, Show (input Symbolic), Show output, Typeable output) =>
   Command {
@@ -406,7 +407,7 @@ commandGenOK (Command inputGen _ _) state =
 -- | An instantiation of a 'Command' which can be executed, and its effect
 --   evaluated.
 --
-data Action m (state :: (* -> *) -> *) =
+data Action m (state :: (Type -> Type) -> Type) =
   forall input output.
   (HTraversable input, Show (input Symbolic), Show output) =>
   Action {

hedgehog/src/Hedgehog/Internal/TH.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Hedgehog.Internal.TH (
@@ -14,11 +15,30 @@ import qualified Data.Ord as Ord
 import           Hedgehog.Internal.Discovery
 import           Hedgehog.Internal.Property
 
-import           Language.Haskell.TH (Exp(..), Q, TExp, location, runIO)
-import           Language.Haskell.TH.Syntax (Loc(..), mkName, unTypeQ, unsafeTExpCoerce)
+import           Language.Haskell.TH (Exp(..), Q, location, runIO
+#if MIN_VERSION_template_haskell(2,17,0)
+  , CodeQ, joinCode, unTypeCode, unsafeCodeCoerce
+#endif
+  )
+import           Language.Haskell.TH.Syntax (Loc(..), mkName
+#if !MIN_VERSION_template_haskell(2,17,0)
+  , TExp, unsafeTExpCoerce, unTypeQ
+#endif
+  )
 
-type TExpQ a =
-  Q (TExp a)
+#if MIN_VERSION_template_haskell(2,17,0)
+type TExpQ a = CodeQ a
+#else
+-- Originally `Code` is a more polymorphic newtype wrapper, but for this module
+-- we can get away with just making it a type alias.
+type TExpQ a = Q (TExp a)
+joinCode :: Q (TExpQ a) -> TExpQ a
+joinCode = (>>= id)
+unsafeCodeCoerce :: Q Exp -> TExpQ a
+unsafeCodeCoerce = unsafeTExpCoerce
+unTypeCode ::  TExpQ a -> Q Exp
+unTypeCode = unTypeQ
+#endif
 
 -- | Discover all the properties in a module.
 --
@@ -28,7 +48,7 @@ discover :: TExpQ Group
 discover = discoverPrefix "prop_"
 
 discoverPrefix :: String -> TExpQ Group
-discoverPrefix prefix = do
+discoverPrefix prefix = joinCode $ do
   file <- getCurrentFile
   properties <- Map.toList <$> runIO (readProperties prefix file)
 
@@ -44,24 +64,24 @@ discoverPrefix prefix = do
       fmap (mkNamedProperty . fst) $
       List.sortBy startLine properties
 
-  [|| Group $$(moduleName) $$(listTE names) ||]
+  return [|| Group $$(moduleName) $$(listTE names) ||]
 
 mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)
-mkNamedProperty name = do
+mkNamedProperty name =
   [|| (name, $$(unsafeProperty name)) ||]
 
 unsafeProperty :: PropertyName -> TExpQ Property
 unsafeProperty =
-  unsafeTExpCoerce . pure . VarE . mkName . unPropertyName
+  unsafeCodeCoerce . pure . VarE . mkName . unPropertyName
 
 listTE :: [TExpQ a] -> TExpQ [a]
-listTE xs = do
-  unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs
+listTE xs =
+  unsafeCodeCoerce $ pure . ListE =<< traverse unTypeCode xs
 
 moduleName :: TExpQ GroupName
-moduleName = do
+moduleName = joinCode $ do
   loc <- GroupName . loc_module <$> location
-  [|| loc ||]
+  return [|| loc ||]
 
 getCurrentFile :: Q FilePath
 getCurrentFile =