th-test-utils 1.1.1 → 1.2.0
raw patch · 9 files changed
+578/−519 lines, 9 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- CHANGELOG.md +8/−6
- README.md +3/−3
- src/Language/Haskell/TH/TestUtils.hs +193/−156
- src/Language/Haskell/TH/TestUtils/QMode.hs +7/−9
- src/Language/Haskell/TH/TestUtils/QState.hs +36/−40
- test/Main.hs +321/−294
- test/TH.hs +4/−4
- test/TestLib.hs +0/−1
- th-test-utils.cabal +6/−6
CHANGELOG.md view
@@ -1,10 +1,12 @@-## Upcoming+# v1.2.0 -## 1.1.1+* Drop support for GHC < 8.10 +# v1.1.1+ * Support GHC 9.2 -## 1.1.0+# v1.1.0 * Rewrite with `runTestQ`, allowing for both recoverable `Q` actions and mocked `Q` actions in `IO`. @@ -17,15 +19,15 @@ with the other helpers defined as before, using `tryQ'`. -## 1.0.2+# v1.0.2 * Support GHC 8.10 -## 1.0.1+# v1.0.1 * Support GHC 8.8 -## 1.0.0+# v1.0.0 Initial release:
README.md view
@@ -1,8 +1,8 @@ # th-test-utils ---[](https://codecov.io/gh/LeapYear/th-test-utils)+[](https://github.com/LeapYear/th-test-utils/actions?query=branch%3Amain)+[](https://codecov.io/gh/LeapYear/th-test-utils)+[](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.
src/Language/Haskell/TH/TestUtils.hs view
@@ -1,11 +1,3 @@-{-|-Module : Language.Haskell.TH.TestUtils-Maintainer : Brandon Chinn <brandon@leapyear.io>-Stability : experimental-Portability : portable--This module defines utilites for testing Template Haskell code.--} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -16,31 +8,37 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Language.Haskell.TH.TestUtils- ( -- * Configuring TestQ- QState(..)- , MockedMode(..)- , QMode(..)- , ReifyInfo(..)- , loadNames- , unmockedState- -- * Running TestQ- , runTestQ- , runTestQErr- , tryTestQ- ) where+{- |+Module : Language.Haskell.TH.TestUtils+Maintainer : Brandon Chinn <brandon@leapyear.io>+Stability : experimental+Portability : portable -#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail (MonadFail(..))-#endif-import Control.Monad.IO.Class (MonadIO(..))+This module defines utilites for testing Template Haskell code.+-}+module Language.Haskell.TH.TestUtils (+ -- * Configuring TestQ+ QState (..),+ MockedMode (..),+ QMode (..),+ ReifyInfo (..),+ loadNames,+ unmockedState,++ -- * Running TestQ+ runTestQ,+ runTestQErr,+ tryTestQ,+) where++import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.Except as Except import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State as State import Data.Maybe (fromMaybe) import Language.Haskell.TH (Name, Q, runIO, runQ)-import Language.Haskell.TH.Syntax (Quasi(..), mkNameU)+import Language.Haskell.TH.Syntax (Quasi (..), mkNameU) import Language.Haskell.TH.TestUtils.QMode import Language.Haskell.TH.TestUtils.QState@@ -61,30 +59,35 @@ where runTestQMonad = Except.runExceptT- . (`State.evalStateT` initialInternalState)- . (`Reader.runReaderT` state)- . unTestQ+ . (`State.evalStateT` initialInternalState)+ . (`Reader.runReaderT` state)+ . unTestQ - initialInternalState = InternalState- { lastErrorReport = Nothing- , newNameCounter = 0- }+ initialInternalState =+ InternalState+ { lastErrorReport = Nothing+ , newNameCounter = 0+ } data InternalState = InternalState { lastErrorReport :: Maybe String- , newNameCounter :: Int+ , newNameCounter :: Int } newtype TestQ (mode :: MockedMode) a = TestQ- { unTestQ- :: Reader.ReaderT (QState mode)- ( State.StateT InternalState- ( Except.ExceptT String- Q- )- )- a- } deriving (Functor, Applicative, Monad)+ { unTestQ ::+ Reader.ReaderT+ (QState mode)+ ( State.StateT+ InternalState+ ( Except.ExceptT+ String+ Q+ )+ )+ a+ }+ deriving (Functor, Applicative, Monad) {- TestQ stack: ReaderT -} @@ -107,12 +110,12 @@ getLastError = TestQ . lift $ State.gets lastErrorReport storeLastError :: String -> TestQ mode ()-storeLastError msg = TestQ . lift $ State.modify (\state -> state { lastErrorReport = Just msg })+storeLastError msg = TestQ . lift $ State.modify (\state -> state{lastErrorReport = Just msg}) getAndIncrementNewNameCounter :: TestQ mode Int getAndIncrementNewNameCounter = TestQ . lift $ State.state $ \state -> let n = newNameCounter state- in (n, state { newNameCounter = n + 1 })+ in (n, state{newNameCounter = n + 1}) {- TestQ stack: ExceptT -} @@ -146,13 +149,13 @@ use Override{..} = do mode <- getMode case (mode, whenMocked) of- (AllowQ, _) -> liftQ whenAllowed- (_, DoInstead testQ) -> testQ+ (AllowQ, _) -> liftQ whenAllowed+ (_, DoInstead testQ) -> testQ (_, Unsupported label) -> error $ "Cannot run '" ++ label ++ "' with TestQ" data Override mode a = Override { whenAllowed :: Q a- , whenMocked :: WhenMocked mode a+ , whenMocked :: WhenMocked mode a } data WhenMocked mode a@@ -162,133 +165,167 @@ instance Quasi (TestQ mode) where {- IO -} - qRunIO io = getMode >>= \case- MockQ -> error "IO actions not allowed"- _ -> liftIO io+ qRunIO io =+ getMode >>= \case+ MockQ -> error "IO actions not allowed"+ _ -> liftIO io {- Error handling + reporting -} qRecover handler action = action `catchError` const handler - qReport False msg = use Override- { whenAllowed = qReport False msg- , whenMocked = DoInstead $ return ()- }+ qReport False msg =+ use+ Override+ { whenAllowed = qReport False msg+ , whenMocked = DoInstead $ return ()+ } qReport True msg = storeLastError msg {- Names -} - qNewName name = use Override- { whenAllowed = qNewName name- , whenMocked = DoInstead $ mkNameU name . fromIntegral <$> getAndIncrementNewNameCounter- }+ qNewName name =+ use+ Override+ { whenAllowed = qNewName name+ , whenMocked = DoInstead $ mkNameU name . fromIntegral <$> getAndIncrementNewNameCounter+ } - qLookupName b name = use Override- { whenAllowed = qLookupName b name- , whenMocked = DoInstead $ do- QState{knownNames} <- getState- return $ lookup name knownNames- }+ qLookupName b name =+ use+ Override+ { whenAllowed = qLookupName b name+ , whenMocked = DoInstead $ do+ QState{knownNames} <- getState+ return $ lookup name knownNames+ } {- ReifyInfo -} - qReify name = use Override- { whenAllowed = qReify name- , whenMocked = DoInstead $ lookupReifyInfo reifyInfoInfo name- }+ qReify name =+ use+ Override+ { whenAllowed = qReify name+ , whenMocked = DoInstead $ lookupReifyInfo reifyInfoInfo name+ } - qReifyFixity name = use Override- { whenAllowed = qReifyFixity name- , whenMocked = DoInstead $ lookupReifyInfo reifyInfoFixity name- }+ qReifyFixity name =+ use+ Override+ { whenAllowed = qReifyFixity name+ , whenMocked = DoInstead $ lookupReifyInfo reifyInfoFixity name+ } - qReifyRoles name = use Override- { whenAllowed = qReifyRoles name- , whenMocked = DoInstead $ lookupReifyInfo reifyInfoRoles name >>= \case- Nothing -> error $ "No roles associated with " ++ show name- Just roles -> return roles- }+ qReifyRoles name =+ use+ Override+ { whenAllowed = qReifyRoles name+ , whenMocked =+ DoInstead $+ lookupReifyInfo reifyInfoRoles name >>= \case+ Nothing -> error $ "No roles associated with " ++ show name+ Just roles -> return roles+ } -#if MIN_VERSION_template_haskell(2,16,0)- qReifyType name = use Override- { whenAllowed = qReifyType name- , whenMocked = DoInstead $ lookupReifyInfo reifyInfoType name- }-#endif+ qReifyType name =+ use+ Override+ { whenAllowed = qReifyType name+ , whenMocked = DoInstead $ lookupReifyInfo reifyInfoType name+ } {- Currently unsupported -} - qReifyInstances name types = use Override- { whenAllowed = qReifyInstances name types- , whenMocked = Unsupported "qReifyInstances"- }- qReifyAnnotations annlookup = use Override- { whenAllowed = qReifyAnnotations annlookup- , whenMocked = Unsupported "qReifyAnnotations"- }- qReifyModule mod' = use Override- { whenAllowed = qReifyModule mod'- , whenMocked = Unsupported "qReifyModule"- }- qReifyConStrictness name = use Override- { whenAllowed = qReifyConStrictness name- , whenMocked = Unsupported "qReifyConStrictness"- }- qLocation = use Override- { whenAllowed = qLocation- , whenMocked = Unsupported "qLocation"- }- qAddDependentFile fp = use Override- { whenAllowed = qAddDependentFile fp- , whenMocked = Unsupported "qAddDependentFile"- }- qAddTopDecls decls = use Override- { whenAllowed = qAddTopDecls decls- , whenMocked = Unsupported "qAddTopDecls"- }- qAddModFinalizer q = use Override- { whenAllowed = qAddModFinalizer q- , whenMocked = Unsupported "qAddModFinalizer"- }- qGetQ = use Override- { whenAllowed = qGetQ- , whenMocked = Unsupported "qGetQ"- }- qPutQ a = use Override- { whenAllowed = qPutQ a- , whenMocked = Unsupported "qPutQ"- }- qIsExtEnabled ext = use Override- { whenAllowed = qIsExtEnabled ext- , whenMocked = Unsupported "qIsExtEnabled"- }- qExtsEnabled = use Override- { whenAllowed = qExtsEnabled- , whenMocked = Unsupported "qExtsEnabled"- }--#if MIN_VERSION_template_haskell(2,13,0)- qAddCorePlugin plugin = use Override- { whenAllowed = qAddCorePlugin plugin- , whenMocked = Unsupported "qAddCorePlugin"- }-#endif--#if MIN_VERSION_template_haskell(2,14,0)- qAddTempFile suffix = use Override- { whenAllowed = qAddTempFile suffix- , whenMocked = Unsupported "qAddTempFile"- }- qAddForeignFilePath lang fp = use Override- { whenAllowed = qAddForeignFilePath lang fp- , whenMocked = Unsupported "qAddForeignFilePath"- }-#elif MIN_VERSION_template_haskell(2,12,0)- qAddForeignFile lang fp = use Override- { whenAllowed = qAddForeignFile lang fp- , whenMocked = Unsupported "qAddForeignFile"- }-#endif+ qReifyInstances name types =+ use+ Override+ { whenAllowed = qReifyInstances name types+ , whenMocked = Unsupported "qReifyInstances"+ }+ qReifyAnnotations annlookup =+ use+ Override+ { whenAllowed = qReifyAnnotations annlookup+ , whenMocked = Unsupported "qReifyAnnotations"+ }+ qReifyModule mod' =+ use+ Override+ { whenAllowed = qReifyModule mod'+ , whenMocked = Unsupported "qReifyModule"+ }+ qReifyConStrictness name =+ use+ Override+ { whenAllowed = qReifyConStrictness name+ , whenMocked = Unsupported "qReifyConStrictness"+ }+ qLocation =+ use+ Override+ { whenAllowed = qLocation+ , whenMocked = Unsupported "qLocation"+ }+ qAddDependentFile fp =+ use+ Override+ { whenAllowed = qAddDependentFile fp+ , whenMocked = Unsupported "qAddDependentFile"+ }+ qAddTopDecls decls =+ use+ Override+ { whenAllowed = qAddTopDecls decls+ , whenMocked = Unsupported "qAddTopDecls"+ }+ qAddModFinalizer q =+ use+ Override+ { whenAllowed = qAddModFinalizer q+ , whenMocked = Unsupported "qAddModFinalizer"+ }+ qGetQ =+ use+ Override+ { whenAllowed = qGetQ+ , whenMocked = Unsupported "qGetQ"+ }+ qPutQ a =+ use+ Override+ { whenAllowed = qPutQ a+ , whenMocked = Unsupported "qPutQ"+ }+ qIsExtEnabled ext =+ use+ Override+ { whenAllowed = qIsExtEnabled ext+ , whenMocked = Unsupported "qIsExtEnabled"+ }+ qExtsEnabled =+ use+ Override+ { whenAllowed = qExtsEnabled+ , whenMocked = Unsupported "qExtsEnabled"+ }+ qAddCorePlugin plugin =+ use+ Override+ { whenAllowed = qAddCorePlugin plugin+ , whenMocked = Unsupported "qAddCorePlugin"+ }+ qAddTempFile suffix =+ use+ Override+ { whenAllowed = qAddTempFile suffix+ , whenMocked = Unsupported "qAddTempFile"+ }+ qAddForeignFilePath lang fp =+ use+ Override+ { whenAllowed = qAddForeignFilePath lang fp+ , whenMocked = Unsupported "qAddForeignFilePath"+ } #if MIN_VERSION_template_haskell(2,18,0) qPutDoc loc doc = use Override
src/Language/Haskell/TH/TestUtils/QMode.hs view
@@ -5,11 +5,11 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Language.Haskell.TH.TestUtils.QMode- ( MockedMode(..)- , QMode(..)- , IsMockedMode(..)- ) where+module Language.Haskell.TH.TestUtils.QMode (+ MockedMode (..),+ QMode (..),+ IsMockedMode (..),+) where import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift)@@ -42,15 +42,13 @@ data QMode (mode :: MockedMode) where -- | All Q actions are mocked and IO actions are disallowed.- MockQ :: QMode 'FullyMocked-+ MockQ :: QMode 'FullyMocked -- | Same as MockQ, except IO actions are passed through. -- Useful if your TH code, for example, reads files with runIO. MockQAllowIO :: QMode 'FullyMockedWithIO- -- | No mocking is done. -- Useful for running Q as normal, but you need to get error messages.- AllowQ :: QMode 'NotMocked+ AllowQ :: QMode 'NotMocked deriving instance Show (QMode mode) deriving instance Lift (QMode mode)
src/Language/Haskell/TH/TestUtils/QState.hs view
@@ -1,67 +1,63 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} -module Language.Haskell.TH.TestUtils.QState- ( QState(..)- , ReifyInfo(..)- , loadNames- , unmockedState- ) where+module Language.Haskell.TH.TestUtils.QState (+ QState (..),+ ReifyInfo (..),+ loadNames,+ unmockedState,+) where import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax (Lift)-#if MIN_VERSION_template_haskell(2,16,0)-import qualified Language.Haskell.TH.Syntax as TH-#endif -import Language.Haskell.TH.TestUtils.QMode (MockedMode(..), QMode(..))+import Language.Haskell.TH.TestUtils.QMode (MockedMode (..), QMode (..)) -- | State information for mocking Q functionality. data QState (mode :: MockedMode) = QState- { mode :: QMode mode+ { mode :: QMode mode , knownNames :: [(String, Name)]- -- ^ Names that can be looked up with 'lookupTypeName' or 'lookupValueName'- , reifyInfo :: [(Name, ReifyInfo)]- -- ^ Reification information for Names to return when 'reify' is called.- } deriving (Show, Lift)+ -- ^ Names that can be looked up with 'lookupTypeName' or 'lookupValueName'+ , reifyInfo :: [(Name, ReifyInfo)]+ -- ^ Reification information for Names to return when 'reify' is called.+ }+ deriving (Show, Lift) data ReifyInfo = ReifyInfo- { reifyInfoInfo :: Info+ { reifyInfoInfo :: Info , reifyInfoFixity :: Maybe Fixity- , reifyInfoRoles :: Maybe [Role]- , reifyInfoType :: Type- } deriving (Show, Lift)+ , reifyInfoRoles :: Maybe [Role]+ , reifyInfoType :: Type+ }+ deriving (Show, Lift) --- | A helper for loading names for 'reifyInfo'------ Usage:------ > QState--- > { reifyInfo = $(loadNames [''Int, ''Maybe])--- > , ...--- > }+{- | A helper for loading names for 'reifyInfo'++ Usage:++ > QState+ > { reifyInfo = $(loadNames [''Int, ''Maybe])+ > , ...+ > }+-} loadNames :: [Name] -> ExpQ loadNames names = listE $ flip map names $ \name -> do info <- reify name fixity <- reifyFixity name roles <- recover (pure Nothing) $ Just <$> reifyRoles name-#if MIN_VERSION_template_haskell(2,16,0)- let infoType = reifyType name >>= TH.lift-#else- let infoType = [| error "Your version of template-haskell does not have 'reifyType'" |]-#endif+ infoType <- reifyType name - [| (name, ReifyInfo info fixity roles $infoType) |]+ [|(name, ReifyInfo info fixity roles infoType)|] -- | A shortcut for defining an unmocked Q. unmockedState :: QState 'NotMocked-unmockedState = QState- { mode = AllowQ- , knownNames = []- , reifyInfo = []- }+unmockedState =+ QState+ { mode = AllowQ+ , knownNames = []+ , reifyInfo = []+ }
test/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}@@ -8,198 +7,217 @@ {-# LANGUAGE TypeApplications #-} import Control.Monad (join)-#if MIN_VERSION_template_haskell(2,13,0) import Control.Monad.IO.Class (liftIO)-#endif import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.List (intercalate)-import Language.Haskell.TH (AnnLookup(..), Q, Type(..), runIO)-import Language.Haskell.TH.Syntax (Extension(..), Quasi(..))-#if MIN_VERSION_template_haskell(2,12,0)-import Language.Haskell.TH.Syntax (ForeignSrcLang(..))-#endif+import Language.Haskell.TH (AnnLookup (..), Q, Type (..), runIO)+import Language.Haskell.TH.Syntax (Extension (..), ForeignSrcLang (..), Quasi (..)) import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit import Language.Haskell.TH.TestUtils import Language.Haskell.TH.TestUtils.QMode (IsMockedMode, TestQResult)-import TestLib import TH+import TestLib main :: IO ()-main = defaultMain $ testGroup "th-test-utils"- [ testAllowQ- , testMockQ- , testMockQAllowIO- ]+main =+ defaultMain $+ testGroup+ "th-test-utils"+ [ testAllowQ+ , testMockQ+ , testMockQAllowIO+ ] testAllowQ :: TestTree-testAllowQ = testGroup "AllowQ"- [ testRunners- , testMethods- ]+testAllowQ =+ testGroup+ "AllowQ"+ [ testRunners+ , testMethods+ ] where- testRunners = testGroup "tryTestQ, runTestQ, runTestQErr"- [ $(testCaseTH "tryTestQ - success" $ do- 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- )- , $(testCaseTH "fmap Right . runTestQ === tryTestQ" $ do- 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- )- , $(testCaseTH "fmap Left . runTestQErr === tryTestQ" $ do- 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"- )- ]- testMethods = testGroup "Quasi methods"- [ $(testCaseTH "qNewName" $- 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"- )- , $(testCaseTH "qRecover" $ do- 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"- ]- )- , $(testCaseTH "qReify" $- checkUnmockedMatches $ qReify ''Maybe- )- , $(testCaseTH "qReifyFixity" $- checkUnmockedMatches $ qReifyFixity '($)- )-#if MIN_VERSION_template_haskell(2,16,0)- , $(testCaseTH "qReifyType" $- checkUnmockedMatches $ qReifyType ''Maybe- )-#endif- , $(testCaseTH "qReifyInstances" $- checkUnmockedMatches $ qReifyInstances ''Show [ConT ''Int]- )- , $(testCaseTH "qReifyRoles" $- checkUnmockedMatches $ qReifyRoles ''Maybe- )- , $(testCaseTH "qReifyAnnotations" $- checkUnmockedMatches $ qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)- )- , $(testCaseTH "qReifyModule" $- checkUnmockedMatches $ qReifyModule $(thisModule)- )- , $(testCaseTH "qReifyConStrictness" $- checkUnmockedMatches $ qReifyConStrictness 'Just- )- , $(testCaseTH "qLocation" $- checkUnmockedMatches qLocation- )- , $(testCaseTH "qRunIO, qAddDependentFile" $- 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- )-#if MIN_VERSION_template_haskell(2,14,0)- , $(testCaseTH "qAddTempFile, qAddForeignFilePath" $ isSuccess $ do- fp <- runTestQ unmockedState $ qAddTempFile "c"- qRunIO $ writeFile fp "#include <stdio.h>"- runTestQ unmockedState $ qAddForeignFilePath LangC fp- )-#elif MIN_VERSION_template_haskell(2,12,0)- , $(testCaseTH "qAddForeignFile" $- isSuccess $ runTestQ unmockedState $ qAddForeignFile LangC "#include <stdio.h>"- )-#endif- , $(testCaseTH "qAddModFinalizer" $- isSuccess $ runTestQ unmockedState $ qAddModFinalizer $ return ()- )-- -- Not testing qAddCorePlugin because I don't want to actually register plugins here+ testRunners =+ testGroup+ "tryTestQ, runTestQ, runTestQErr"+ [ $( testCaseTH "tryTestQ - success" $ do+ 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+ )+ , $( testCaseTH "fmap Right . runTestQ === tryTestQ" $ do+ 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+ )+ , $( testCaseTH "fmap Left . runTestQErr === tryTestQ" $ do+ 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"+ )+ ]+ testMethods =+ testGroup+ "Quasi methods"+ [ $( testCaseTH "qNewName" $+ 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"+ )+ , $( testCaseTH "qRecover" $ do+ 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"+ ]+ )+ , $( testCaseTH "qReify" $+ checkUnmockedMatches $+ qReify ''Maybe+ )+ , $( testCaseTH "qReifyFixity" $+ checkUnmockedMatches $+ qReifyFixity '($)+ )+ , $( testCaseTH "qReifyType" $+ checkUnmockedMatches $+ qReifyType ''Maybe+ )+ , $( testCaseTH "qReifyInstances" $+ checkUnmockedMatches $+ qReifyInstances ''Show [ConT ''Int]+ )+ , $( testCaseTH "qReifyRoles" $+ checkUnmockedMatches $+ qReifyRoles ''Maybe+ )+ , $( testCaseTH "qReifyAnnotations" $+ checkUnmockedMatches $+ qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)+ )+ , $( testCaseTH "qReifyModule" $+ checkUnmockedMatches $+ qReifyModule $(thisModule)+ )+ , $( testCaseTH "qReifyConStrictness" $+ checkUnmockedMatches $+ qReifyConStrictness 'Just+ )+ , $( testCaseTH "qLocation" $+ checkUnmockedMatches qLocation+ )+ , $( testCaseTH "qRunIO, qAddDependentFile" $+ 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+ )+ , $( testCaseTH "qAddTempFile, qAddForeignFilePath" $ isSuccess $ do+ fp <- runTestQ unmockedState $ qAddTempFile "c"+ qRunIO $ writeFile fp "#include <stdio.h>"+ runTestQ unmockedState $ qAddForeignFilePath LangC fp+ )+ , $( testCaseTH "qAddModFinalizer" $+ 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- )- , $(testCaseTH "qIsExtEnabled" $- checkUnmockedMatches $ sequence- [ qIsExtEnabled JavaScriptFFI- , qIsExtEnabled TemplateHaskell- ]- )- , $(testCaseTH "qExtsEnabled" $- checkUnmockedMatches qExtsEnabled- )- ]+ $( testCaseTH "qGetQ, qPutQ" $+ checkUnmockedMatches $ do+ qPutQ "Hello"+ qGetQ @_ @String+ )+ , $( testCaseTH "qIsExtEnabled" $+ checkUnmockedMatches $+ sequence+ [ qIsExtEnabled JavaScriptFFI+ , qIsExtEnabled TemplateHaskell+ ]+ )+ , $( testCaseTH "qExtsEnabled" $+ checkUnmockedMatches qExtsEnabled+ )+ ] testMockQ :: TestTree-testMockQ = testMockQ' MockQTests- { qMode = MockQ- , toIO = pure- , qRunIOResult = \_ -> Left "IO actions not allowed"- }+testMockQ =+ testMockQ'+ MockQTests+ { qMode = MockQ+ , toIO = pure+ , qRunIOResult = \_ -> Left "IO actions not allowed"+ } testMockQAllowIO :: TestTree-testMockQAllowIO = testMockQ' MockQTests- { qMode = MockQAllowIO- , toIO = id- , qRunIOResult = Right- }+testMockQAllowIO =+ testMockQ'+ MockQTests+ { qMode = MockQAllowIO+ , toIO = id+ , qRunIOResult = Right+ } {- Helpers -} data MockQTests mode = MockQTests- { qMode :: QMode mode- , toIO :: forall a. TestQResult mode a -> IO a+ { qMode :: QMode mode+ , toIO :: forall a. TestQResult mode a -> IO a , qRunIOResult :: forall a. a -> Either String a } -- | Tests for both MockQ and MockQAllowIO, since they should behave exactly the same except for qRunIO. testMockQ' :: forall mode. IsMockedMode mode => MockQTests mode -> TestTree-testMockQ' MockQTests{..} = testGroup (show qMode)- [ testRunners- , testMethods- ]+testMockQ' MockQTests{..} =+ testGroup+ (show qMode)+ [ testRunners+ , testMethods+ ] where- mockedState = QState- { mode = qMode- , knownNames = []- , reifyInfo = []- }+ mockedState =+ QState+ { mode = qMode+ , knownNames = []+ , reifyInfo = []+ } -- Call runTestQ, converting the result to IO and ensuring that the result is evaluated runTestQ' :: QState mode -> Q a -> IO a@@ -209,147 +227,156 @@ runTestQWithErrors :: QState mode -> Q a -> IO (Either String a) runTestQWithErrors state = tryIO . runTestQ' state - testRunners = testGroup "tryTestQ, runTestQ, runTestQErr"- [ testCase "tryTestQ - success" $ do- let x = 1- result <- toIO $ tryTestQ mockedState (return x :: Q Int)- (result :: Either String Int) @?= Right x- , testCase "tryTestQ - error" $ do- let msg = "Error message"- result <- toIO $ tryTestQ mockedState (fail msg :: Q Int)- (result :: Either String Int) @?= Left msg- , testCase "Right . runTestQ === tryTestQ" $ do- actual <- fmap Right $ toIO $ runTestQ mockedState basicSuccess- expected <- toIO $ tryTestQ mockedState basicSuccess- (actual :: Either String String) @?= (expected :: Either String String)- , testCase "runTestQ errors on failure" $ do- let msg = "Error message"- result <- tryIO $ forceM $ toIO $ runTestQ mockedState (fail msg :: Q ())- (result :: Either String ()) @?= Left msg- , testCase "Left . runTestQErr === tryTestQ" $ do- actual <- fmap Left $ toIO $ runTestQErr mockedState basicFailure- expected <- toIO $ tryTestQ mockedState basicFailure- (actual :: Either String String) @?= (expected :: Either String String)- , testCase "runTestQErr errors on success" $ do- result <- tryIO $ forceM $ toIO $ runTestQErr mockedState (return 1 :: Q Int)- (result :: Either String String) @?= Left "Unexpected success: 1"- ]+ testRunners =+ testGroup+ "tryTestQ, runTestQ, runTestQErr"+ [ testCase "tryTestQ - success" $ do+ let x = 1+ result <- toIO $ tryTestQ mockedState (return x :: Q Int)+ (result :: Either String Int) @?= Right x+ , testCase "tryTestQ - error" $ do+ let msg = "Error message"+ result <- toIO $ tryTestQ mockedState (fail msg :: Q Int)+ (result :: Either String Int) @?= Left msg+ , testCase "Right . runTestQ === tryTestQ" $ do+ actual <- fmap Right $ toIO $ runTestQ mockedState basicSuccess+ expected <- toIO $ tryTestQ mockedState basicSuccess+ (actual :: Either String String) @?= (expected :: Either String String)+ , testCase "runTestQ errors on failure" $ do+ let msg = "Error message"+ result <- tryIO $ forceM $ toIO $ runTestQ mockedState (fail msg :: Q ())+ (result :: Either String ()) @?= Left msg+ , testCase "Left . runTestQErr === tryTestQ" $ do+ actual <- fmap Left $ toIO $ runTestQErr mockedState basicFailure+ expected <- toIO $ tryTestQ mockedState basicFailure+ (actual :: Either String String) @?= (expected :: Either String String)+ , testCase "runTestQErr errors on success" $ do+ result <- tryIO $ forceM $ toIO $ runTestQErr mockedState (return 1 :: Q Int)+ (result :: Either String String) @?= Left "Unexpected success: 1"+ ] - testMethods = testGroup "Quasi methods"- [ golden "qNewName" $- join $ runTestQ' mockedState $ do- name1 <- qNewName "foo"- name2 <- qNewName "foo"- name3 <- qNewName "bar"- return $ labelled- [ ("Name 1", pure name1)- , ("Name 2", pure name2)- , ("Name 3", pure name3)- ]- , testCase "qReport" $ do- warningResult <- runTestQ' mockedState $ qReport False "A warning message"- warningResult @?= ()+ testMethods =+ testGroup+ "Quasi methods"+ [ golden "qNewName" $+ join $+ runTestQ' mockedState $ do+ name1 <- qNewName "foo"+ name2 <- qNewName "foo"+ name3 <- qNewName "bar"+ return $+ labelled+ [ ("Name 1", pure name1)+ , ("Name 2", pure name2)+ , ("Name 3", pure name3)+ ]+ , testCase "qReport" $ do+ warningResult <- runTestQ' mockedState $ qReport False "A warning message"+ warningResult @?= () - errorResult <- runTestQ' mockedState $ qReport True "An error message"- errorResult @?= ()- , testCase "qRecover" $ do- let x = "Success"- result <- runTestQ' mockedState $ qRecover (return x) basicFailure- result @?= x- , testCase "qLookupName" $ do- let state = mockedState { knownNames = [("Show", ''Show), ("Right", 'Right)] }+ errorResult <- runTestQ' mockedState $ qReport True "An error message"+ errorResult @?= ()+ , testCase "qRecover" $ do+ let x = "Success"+ result <- runTestQ' mockedState $ qRecover (return x) basicFailure+ result @?= x+ , testCase "qLookupName" $ do+ let state = mockedState{knownNames = [("Show", ''Show), ("Right", 'Right)]} - nameShow <- runTestQ' state $ qLookupName True "Show"- nameShow @?= Just ''Show+ nameShow <- runTestQ' state $ qLookupName True "Show"+ nameShow @?= Just ''Show - nameEq <- runTestQ' state $ qLookupName True "Eq"- nameEq @?= Nothing+ nameEq <- runTestQ' state $ qLookupName True "Eq"+ nameEq @?= Nothing - nameRight <- runTestQ' state $ qLookupName False "Right"- nameRight @?= Just 'Right+ nameRight <- runTestQ' state $ qLookupName False "Right"+ nameRight @?= Just 'Right - nameLeft <- runTestQ' state $ qLookupName False "Left"- nameLeft @?= Nothing- , golden "qReify" $ do- let state = mockedState { reifyInfo = $(loadNames ['putStrLn]) }- labelled- [ ("Found", runTestQWithErrors state $ qReify 'putStrLn)- , ("Missing", runTestQWithErrors state $ qReify ''Show)- ]- , golden "qReifyFixity" $ do- let state = mockedState { reifyInfo = $(loadNames ['($)]) }- labelled- [ ("Found", runTestQWithErrors state $ qReifyFixity '($))- , ("Missing", runTestQWithErrors state $ qReifyFixity '(+))- ]-#if MIN_VERSION_template_haskell(2,16,0)- , golden "qReifyType" $ do- let state = mockedState { reifyInfo = $(loadNames [''Maybe]) }- labelled- [ ("Found", runTestQWithErrors state $ qReifyType ''Maybe)- , ("Missing", runTestQWithErrors state $ qReifyType ''Show)- ]-#endif- , golden "qReifyInstances" $- runUnsupported mockedState $ qReifyInstances ''Show [ConT ''Int]- , golden "qReifyRoles" $ do- let state = mockedState { reifyInfo = $(loadNames [''Maybe, 'map]) }- labelled- [ ("Found", runTestQWithErrors state $ qReifyRoles ''Maybe)- -- reifyRoles errors if name is not of a type constructor- , ("Invalid", runTestQWithErrors state $ qReifyRoles 'map)- , ("Missing", runTestQWithErrors state $ qReifyRoles ''Show)- ]- , golden "qReifyAnnotations" $- runUnsupported mockedState $ qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)- , golden "qReifyModule" $- runUnsupported mockedState $ qReifyModule $(thisModule)- , golden "qReifyConStrictness" $- runUnsupported mockedState $ qReifyConStrictness 'Just- , golden "qLocation" $- runUnsupported mockedState qLocation- , testCase "qRunIO" $ do- let x = 1 :: Int- io = return x+ nameLeft <- runTestQ' state $ qLookupName False "Left"+ nameLeft @?= Nothing+ , golden "qReify" $ do+ let state = mockedState{reifyInfo = $(loadNames ['putStrLn])}+ labelled+ [ ("Found", runTestQWithErrors state $ qReify 'putStrLn)+ , ("Missing", runTestQWithErrors state $ qReify ''Show)+ ]+ , golden "qReifyFixity" $ do+ let state = mockedState{reifyInfo = $(loadNames ['($)])}+ labelled+ [ ("Found", runTestQWithErrors state $ qReifyFixity '($))+ , ("Missing", runTestQWithErrors state $ qReifyFixity '(+))+ ]+ , golden "qReifyType" $ do+ let state = mockedState{reifyInfo = $(loadNames [''Maybe])}+ labelled+ [ ("Found", runTestQWithErrors state $ qReifyType ''Maybe)+ , ("Missing", runTestQWithErrors state $ qReifyType ''Show)+ ]+ , golden "qReifyInstances" $+ runUnsupported mockedState $+ qReifyInstances ''Show [ConT ''Int]+ , golden "qReifyRoles" $ do+ let state = mockedState{reifyInfo = $(loadNames [''Maybe, 'map])}+ labelled+ [ ("Found", runTestQWithErrors state $ qReifyRoles ''Maybe)+ , -- reifyRoles errors if name is not of a type constructor+ ("Invalid", runTestQWithErrors state $ qReifyRoles 'map)+ , ("Missing", runTestQWithErrors state $ qReifyRoles ''Show)+ ]+ , golden "qReifyAnnotations" $+ runUnsupported mockedState $+ qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)+ , golden "qReifyModule" $+ runUnsupported mockedState $+ qReifyModule $(thisModule)+ , golden "qReifyConStrictness" $+ runUnsupported mockedState $+ qReifyConStrictness 'Just+ , golden "qLocation" $+ runUnsupported mockedState qLocation+ , testCase "qRunIO" $ do+ let x = 1 :: Int+ io = return x - qRunIOResult' <- runTestQWithErrors mockedState $ qRunIO io- qRunIOResult' @?= qRunIOResult x+ qRunIOResult' <- runTestQWithErrors mockedState $ qRunIO io+ qRunIOResult' @?= qRunIOResult x - runIOResult <- runTestQWithErrors mockedState $ runIO io- runIOResult @?= qRunIOResult x+ runIOResult <- runTestQWithErrors mockedState $ runIO io+ runIOResult @?= qRunIOResult x -#if MIN_VERSION_template_haskell(2,13,0)- liftIOResult <- runTestQWithErrors mockedState $ liftIO io- liftIOResult @?= qRunIOResult x-#endif- , golden "qAddDependentFile" $- runUnsupported mockedState $ qAddDependentFile "README.md"- , golden "qAddTopDecls" $- runUnsupported mockedState $ qAddTopDecls []-#if MIN_VERSION_template_haskell(2,14,0)- , golden "qAddTempFile" $- runUnsupported mockedState $ qAddTempFile "c"- , golden "qAddForeignFilePath" $- runUnsupported mockedState $ qAddForeignFilePath LangC "foo.c"-#elif MIN_VERSION_template_haskell(2,12,0)- , golden "qAddForeignFile" $- runUnsupported mockedState $ qAddForeignFile LangC "#include <stdio.h>"-#endif- , golden "qAddModFinalizer" $- runUnsupported mockedState $ qAddModFinalizer $ return ()-#if MIN_VERSION_template_haskell(2,13,0)- , golden "qAddCorePlugin" $- runUnsupported mockedState $ qAddCorePlugin "MyPlugin"-#endif- , golden "qGetQ" $- runUnsupported mockedState $ qGetQ @_ @String- , golden "qPutQ" $- runUnsupported mockedState $ qPutQ "Hello"- , golden "qIsExtEnabled" $- runUnsupported mockedState $ qIsExtEnabled TemplateHaskell- , golden "qExtsEnabled" $- runUnsupported mockedState qExtsEnabled- ]+ liftIOResult <- runTestQWithErrors mockedState $ liftIO io+ liftIOResult @?= qRunIOResult x+ , golden "qAddDependentFile" $+ runUnsupported mockedState $+ qAddDependentFile "README.md"+ , golden "qAddTopDecls" $+ runUnsupported mockedState $+ qAddTopDecls []+ , golden "qAddTempFile" $+ runUnsupported mockedState $+ qAddTempFile "c"+ , golden "qAddForeignFilePath" $+ runUnsupported mockedState $+ qAddForeignFilePath LangC "foo.c"+ , golden "qAddModFinalizer" $+ runUnsupported mockedState $+ qAddModFinalizer $+ return ()+ , golden "qAddCorePlugin" $+ runUnsupported mockedState $+ qAddCorePlugin "MyPlugin"+ , golden "qGetQ" $+ runUnsupported mockedState $+ qGetQ @_ @String+ , golden "qPutQ" $+ runUnsupported mockedState $+ qPutQ "Hello"+ , golden "qIsExtEnabled" $+ runUnsupported mockedState $+ qIsExtEnabled TemplateHaskell+ , golden "qExtsEnabled" $+ runUnsupported mockedState qExtsEnabled+ ] -- force both MockQ and MockQAllowIO to resolve the same goldens golden name = goldenVsString name ("test/goldens/MockQ_" ++ name ++ ".golden")
test/TH.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeApplications #-} module TH where@@ -6,7 +6,7 @@ import Control.Exception (SomeException, displayException, try) import Data.Bifunctor (first) import Language.Haskell.TH-import Language.Haskell.TH.Syntax (Module(..))+import Language.Haskell.TH.Syntax (Module (..)) import Test.Tasty.HUnit (Assertion, testCase, (@?=)) import Language.Haskell.TH.TestUtils (runTestQ, unmockedState)@@ -15,7 +15,7 @@ testCaseTH :: String -> Q Assertion -> ExpQ testCaseTH testName q = do q >>= runIO- [| testCase testName $ return () |]+ [|testCase testName $ return ()|] -- | Check that the given action evalutes. isSuccess :: Q a -> Q Assertion@@ -51,4 +51,4 @@ thisModule = do Module pkgName modName <- Language.Haskell.TH.thisModule -- if only Module had a Lift instance- [| Module pkgName modName |]+ [|Module pkgName modName|]
test/TestLib.hs view
@@ -3,7 +3,6 @@ import Language.Haskell.TH {-# ANN basicSuccess "This is a test annotation" #-}- basicSuccess :: Q String basicSuccess = return "Success"
th-test-utils.cabal view
@@ -1,11 +1,11 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: th-test-utils-version: 1.1.1+version: 1.2.0 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,14 +37,14 @@ ghc-options: -Wall build-depends: base >=4.9 && <5- , template-haskell >=2.11.1.0 && <2.19+ , template-haskell >=2.16 && <2.19 , th-orphans >=0.13.4 && <0.14 , transformers >=0.5.2 && <0.6+ default-language: Haskell2010 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances if impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances- default-language: Haskell2010 test-suite th-test-utils-test type: exitcode-stdio-1.0@@ -62,12 +62,12 @@ , tasty , tasty-golden , tasty-hunit- , template-haskell >=2.11.1.0 && <2.19+ , template-haskell >=2.16 && <2.19 , th-orphans >=0.13.4 && <0.14 , th-test-utils , transformers >=0.5.2 && <0.6+ default-language: Haskell2010 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances if impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances- default-language: Haskell2010