diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# v1.2.3 + +* Support GHC 9.14 + # v1.2.2 * Support GHC 9.6 - 9.12 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,6 @@ # th-test-utils [![GitHub Actions](https://img.shields.io/github/actions/workflow/status/brandonchinn178/th-test-utils/ci.yml?branch=main)](https://github.com/brandonchinn178/th-test-utils/actions?query=branch%3Amain) -[![codecov](https://codecov.io/gh/brandonchinn178/th-test-utils/branch/main/graph/badge.svg)](https://codecov.io/gh/brandonchinn178/th-test-utils) [![Hackage](https://img.shields.io/hackage/v/th-test-utils.svg)](https://hackage.haskell.org/package/th-test-utils) This package implements `tryTestQ` and related helpers in order to better test Template Haskell code. It supports returning the actual error message that [`recover` doesn't currently return](https://gitlab.haskell.org/ghc/ghc/-/issues/2340) as well as mocking out `Q` actions, so that you can run Template Haskell code at runtime. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -47,136 +47,136 @@ testGroup "tryTestQ, runTestQ, runTestQErr" [ $( testCaseTH "tryTestQ - success" $ do - let x = 1 - result <- tryTestQ unmockedState (return x :: Q Int) - return $ result @?= Right x + let x = 1 + result <- tryTestQ unmockedState (return x :: Q Int) + return $ result @?= Right x ) , $( testCaseTH "tryTestQ - error" $ do - let msg = "Error message" - result <- tryTestQ unmockedState (fail msg :: Q Int) - return $ result @?= Left msg + let msg = "Error message" + result <- tryTestQ unmockedState (fail msg :: Q Int) + return $ result @?= Left msg ) , $( testCaseTH "fmap Right . runTestQ === tryTestQ" $ do - actual <- Right <$> runTestQ unmockedState basicSuccess - expected <- tryTestQ unmockedState basicSuccess - return $ actual @?= expected + actual <- Right <$> runTestQ unmockedState basicSuccess + expected <- tryTestQ unmockedState basicSuccess + return $ actual @?= expected ) , $( testCaseTH "runTestQ errors on failure" $ do - let msg = "Error message" - result <- tryQ $ runTestQ unmockedState (fail msg :: Q ()) - return $ result @?= Left msg + let msg = "Error message" + result <- tryQ $ runTestQ unmockedState (fail msg :: Q ()) + return $ result @?= Left msg ) , $( testCaseTH "fmap Left . runTestQErr === tryTestQ" $ do - actual <- Left <$> runTestQErr unmockedState basicFailure - expected <- tryTestQ unmockedState basicFailure - return $ actual @?= expected + actual <- Left <$> runTestQErr unmockedState basicFailure + expected <- tryTestQ unmockedState basicFailure + return $ actual @?= expected ) , $( testCaseTH "runTestQErr errors on success" $ do - result <- tryQ $ runTestQErr unmockedState (return 1 :: Q Int) - return $ result @?= Left "Unexpected success: 1" + result <- tryQ $ runTestQErr unmockedState (return 1 :: Q Int) + return $ result @?= Left "Unexpected success: 1" ) ] testMethods = testGroup "Quasi methods" [ $( testCaseTH "qNewName" $ - isSuccess $ - runTestQ unmockedState $ - qNewName "foo" + isSuccess $ + runTestQ unmockedState $ + qNewName "foo" ) , $( testCaseTH "qReport" $ - -- not testing 'qReport False' because it fails with '-Werror' - -- isSuccess $ runTestQ unmockedState $ qReport False "A warning message" - isSuccess $ - runTestQ unmockedState $ - qReport True "An error message" + -- not testing 'qReport False' because it fails with '-Werror' + -- isSuccess $ runTestQ unmockedState $ qReport False "A warning message" + isSuccess $ + runTestQ unmockedState $ + qReport True "An error message" ) , $( testCaseTH "qRecover" $ do - let x = "Success" - result <- runTestQ unmockedState $ qRecover (return x) basicFailure - return $ result @?= x + let x = "Success" + result <- runTestQ unmockedState $ qRecover (return x) basicFailure + return $ result @?= x ) , $( testCaseTH "qLookupName" $ - checkUnmockedMatches $ - sequence - [ qLookupName True "Show" - , qLookupName True "Right" - , qLookupName False "Right" - , qLookupName False "Show" - ] + checkUnmockedMatches $ + sequence + [ qLookupName True "Show" + , qLookupName True "Right" + , qLookupName False "Right" + , qLookupName False "Show" + ] ) , $( testCaseTH "qReify" $ - checkUnmockedMatches $ - qReify ''Maybe + checkUnmockedMatches $ + qReify ''Maybe ) , $( testCaseTH "qReifyFixity" $ - checkUnmockedMatches $ - qReifyFixity '($) + checkUnmockedMatches $ + qReifyFixity '($) ) , $( testCaseTH "qReifyType" $ - checkUnmockedMatches $ - qReifyType ''Maybe + checkUnmockedMatches $ + qReifyType ''Maybe ) , $( testCaseTH "qReifyInstances" $ - checkUnmockedMatches $ - qReifyInstances ''Show [ConT ''Int] + checkUnmockedMatches $ + qReifyInstances ''Show [ConT ''Int] ) , $( testCaseTH "qReifyRoles" $ - checkUnmockedMatches $ - qReifyRoles ''Maybe + checkUnmockedMatches $ + qReifyRoles ''Maybe ) , $( testCaseTH "qReifyAnnotations" $ - checkUnmockedMatches $ - qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess) + checkUnmockedMatches $ + qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess) ) , $( testCaseTH "qReifyModule" $ - checkUnmockedMatches $ - qReifyModule $(thisModule) + checkUnmockedMatches $ + qReifyModule $(thisModule) ) , $( testCaseTH "qReifyConStrictness" $ - checkUnmockedMatches $ - qReifyConStrictness 'Just + checkUnmockedMatches $ + qReifyConStrictness 'Just ) , $( testCaseTH "qLocation" $ - checkUnmockedMatches qLocation + checkUnmockedMatches qLocation ) , $( testCaseTH "qRunIO, qAddDependentFile" $ - checkUnmockedMatches $ do - readmeContents <- qRunIO $ readFile "README.md" - qAddDependentFile "README.md" - return readmeContents + checkUnmockedMatches $ do + readmeContents <- qRunIO $ readFile "README.md" + qAddDependentFile "README.md" + return readmeContents ) , $( testCaseTH "qAddTopDecls" $ do - decs <- [d|{-# ANN module "AllowQ - qAddTopDecls" #-}|] - isSuccess $ runTestQ unmockedState $ qAddTopDecls decs + decs <- [d|{-# ANN module "AllowQ - qAddTopDecls" #-}|] + isSuccess $ runTestQ unmockedState $ qAddTopDecls decs ) , $( testCaseTH "qAddTempFile, qAddForeignFilePath" $ isSuccess $ do - fp <- runTestQ unmockedState $ qAddTempFile "c" - qRunIO $ writeFile fp "#include " - runTestQ unmockedState $ qAddForeignFilePath LangC fp + fp <- runTestQ unmockedState $ qAddTempFile "c" + qRunIO $ writeFile fp "#include " + runTestQ unmockedState $ qAddForeignFilePath LangC fp ) , $( testCaseTH "qAddModFinalizer" $ - isSuccess $ - runTestQ unmockedState $ - qAddModFinalizer $ - return () + isSuccess $ + runTestQ unmockedState $ + qAddModFinalizer $ + return () ) , -- Not testing qAddCorePlugin because I don't want to actually register plugins here $( testCaseTH "qGetQ, qPutQ" $ - checkUnmockedMatches $ do - qPutQ "Hello" - qGetQ @_ @String + checkUnmockedMatches $ do + qPutQ "Hello" + qGetQ @_ @String ) , $( testCaseTH "qIsExtEnabled" $ - checkUnmockedMatches $ - sequence - [ qIsExtEnabled JavaScriptFFI - , qIsExtEnabled TemplateHaskell - ] + checkUnmockedMatches $ + sequence + [ qIsExtEnabled JavaScriptFFI + , qIsExtEnabled TemplateHaskell + ] ) , $( testCaseTH "qExtsEnabled" $ - checkUnmockedMatches qExtsEnabled + checkUnmockedMatches qExtsEnabled ) ] @@ -384,7 +384,7 @@ -- force both MockQ and MockQAllowIO to resolve the same goldens golden name = goldenVsString name ("test/goldens/MockQ_" ++ name ++ ".golden") - . fmap (TextL.encodeUtf8 . TextL.fromStrict . normalizeGhc910) + . fmap (TextL.encodeUtf8 . TextL.fromStrict . normalizeModules) labelled :: (Show a) => [(String, IO a)] -> IO Text labelled vals = do @@ -396,15 +396,26 @@ runUnsupported :: (Show a) => QState mode -> Q a -> IO Text runUnsupported state q = labelled [("Unsupported", runTestQWithErrors state q)] -{- HLINT ignore "Redundant id" -} -normalizeGhc910 :: Text -> Text -normalizeGhc910 = - id -#if __GLASGOW_HASKELL__ < 910 - . replace "GHC.Show" "GHC.Internal.Show" - . replace "GHC.Base" "GHC.Internal.Base" - . replace "GHC.Num" "GHC.Internal.Num" - . replace "System.IO" "GHC.Internal.System.IO" +normalizeModules :: Text -> Text +normalizeModules s0 = foldr go s0 $ changes910 <> changes914 where - replace old new = Text.replace (Text.pack old) (Text.pack new) + go (old, new) = Text.replace (Text.pack old) (Text.pack new) + +#if __GLASGOW_HASKELL__ < 910 + changes910 = + [ ("GHC.Show", "GHC.Internal.Show") + , ("GHC.Base", "GHC.Internal.Base") + , ("GHC.Num", "GHC.Internal.Num") + , ("System.IO", "GHC.Internal.System.IO") + ] +#else + changes910 = [] +#endif + +#if __GLASGOW_HASKELL__ < 914 + changes914 = + [ ("GHC.Types.IO", "GHC.Internal.Types.IO") + ] +#else + changes914 = [] #endif diff --git a/th-test-utils.cabal b/th-test-utils.cabal --- a/th-test-utils.cabal +++ b/th-test-utils.cabal @@ -1,11 +1,7 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.37.0. --- --- see: https://github.com/sol/hpack - name: th-test-utils -version: 1.2.2 +version: 1.2.3 synopsis: Utility functions for testing Template Haskell code description: Utility functions for testing Template Haskell code, including functions for testing failures in the Q monad. @@ -37,9 +33,9 @@ ghc-options: -Wall build-depends: base >=4.9 && <5 - , template-haskell >=2.16 && <2.24 - , th-orphans >=0.13.4 && <0.14 - , transformers >=0.5.2 && <0.7 + , template-haskell + , th-orphans + , transformers default-language: Haskell2010 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances @@ -61,11 +57,11 @@ , tasty , tasty-golden , tasty-hunit - , template-haskell >=2.16 && <2.24 + , template-haskell , text - , th-orphans >=0.13.4 && <0.14 + , th-orphans , th-test-utils - , transformers >=0.5.2 && <0.7 + , transformers default-language: Haskell2010 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances