packages feed

th-test-utils 1.0.2 → 1.1.0

raw patch · 9 files changed

+846/−218 lines, 9 filesdep +bytestringdep +tasty-goldendep +th-orphansdep ~tastydep ~tasty-hunitdep ~template-haskell

Dependencies added: bytestring, tasty-golden, th-orphans

Dependency ranges changed: tasty, tasty-hunit, template-haskell, transformers

Files

CHANGELOG.md view
@@ -1,5 +1,18 @@ ## Upcoming +## 1.1.0++* Rewrite with `runTestQ`, allowing for both recoverable `Q` actions and mocked `Q` actions in `IO`.++    The previous `tryQ'` function can be reimplemented as:++    ```hs+    tryQ' :: Q a -> Q (Either String a)+    tryQ' = tryTestQ unmockedState+    ```++    with the other helpers defined as before, using `tryQ'`.+ ## 1.0.2  * Support GHC 8.10
README.md view
@@ -2,43 +2,50 @@  ![CircleCI](https://img.shields.io/circleci/build/github/LeapYear/th-test-utils.svg) ![Hackage](https://img.shields.io/hackage/v/th-test-utils.svg)--This package contains utility functions for testing Template Haskell code.+[![codecov](https://codecov.io/gh/LeapYear/th-test-utils/branch/master/graph/badge.svg)](https://codecov.io/gh/LeapYear/th-test-utils) -Currently, this package only exposes a single function, `tryQ` (and derivatives),-that allows testing whether a given Template Haskell expression fails.+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.  ## Usage  ```haskell--- e.g. $(qConcat ["hello", "world"]) generates "helloworld" at compile time-qConcat :: [String] -> Q Exp-qConcat [] = fail "Cannot concat empty list"-qConcat xs = ...---- e.g. [numberify| one |] generates `1` at compile time-numberify :: QuasiQuoter-numberify = ...+-- e.g. $(showInfo "Bool") generates a string corresponding+-- to the reify `Info` for `Bool`.+showInfo :: String -> Q Exp+showInfo s = do+  mName <- lookupTypeName s+  case mName of+    Nothing -> fail $ "Unknown type: " ++ s+    Just name -> do+      info <- reify name+      lift $ show info ```  ```haskell -- example using tasty-hunit main :: IO () main = defaultMain $ testGroup "my-project"-  [ testCase "qConcat 1" $-      $(tryQ $ qConcat ["hello", "world"]) @?= (Right "helloworld" :: Either String String)-  , testCase "qConcat 2" $-      $(tryQ $ qConcat [])                 @?= (Left "Cannot concat empty list" :: Either String String)-  , testCase "numberify 1" $-      $(tryQ $ quoteExp numberify "one")   @?= (Right 1 :: Either String Int)-  , testCase "numberify 2" $-      $(tryQ $ quoteExp numberify "foo")   @?= (Left "not a number" :: Either String Int)+  [ testCase "showInfo unmocked" $(do+      result1 <- tryTestQ unmockedState $ showInfo "Bool"+      runIO $ isRight result1 @? ("Unexpected error: " ++ show result1) -  -- can also return error message as `Maybe String` or `String` (which errors-  -- if the function doesn't error)-  , testCase "numberify 3" $-      $(tryQErr $ quoteExp numberify "foo") @?= Just "not a number"-  , testCase "numberify 4" $-      $(tryQErr' $ quoteExp numberify "foo") @?= "not a number"+      result2 <- tryTestQ unmockedState $ showInfo "Foo"+      runIO $ result2 @?= Left "Unknown type: Foo"++      [| return () |]+    )++  , testCase "showInfo mocked success" $ do+      let state = QState+            { mode = MockQ+            , knownNames = [("Bool", ''Bool)]+            , reifyInfo = $(loadNames [''Bool])+            }++      let result1 = tryTestQ state $ showInfo "Bool"+      isRight result1 @? ("Unexpected error: " ++ show result1)++      let result2 = tryTestQ state $ showInfo "Foo"+      result2 @?= Left "Unknown type: Foo"   ] ```
src/Language/Haskell/TH/TestUtils.hs view
@@ -7,170 +7,285 @@ This module defines utilites for testing Template Haskell code. -} {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}  module Language.Haskell.TH.TestUtils-  ( -- * Error recovery-    -- $tryQ-    tryQ'-  , tryQ-  , tryQErr-  , tryQErr'+  ( -- * Configuring TestQ+    QState(..)+  , MockedMode(..)+  , QMode(..)+  , ReifyInfo(..)+  , loadNames+  , unmockedState+    -- * Running TestQ+  , runTestQ+  , runTestQErr+  , tryTestQ   ) where -import Control.Monad ((>=>))-import qualified Control.Monad.Fail as Fail-#if MIN_VERSION_template_haskell(2,13,0)-import Control.Monad.IO.Class (MonadIO)-#endif-import qualified Control.Monad.Trans.Class as Trans-import Control.Monad.Trans.Except (ExceptT, catchE, runExceptT, throwE)-import Control.Monad.Trans.State (StateT, put, runStateT)-import Language.Haskell.TH (Exp, Q, appE, runQ)-#if MIN_VERSION_template_haskell(2,12,0)-import qualified Language.Haskell.TH as TH+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail(..)) #endif-import Language.Haskell.TH.Syntax (Quasi(..), lift)+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) --- $tryQ------ Unfortunately, there is no built-in way to get an error message of a Template Haskell--- computation, since 'Language.Haskell.TH.recover' throws away the error message. If--- 'Language.Haskell.TH.recover' was defined differently, we could maybe do:------ > recover' :: (String -> Q a) -> Q a -> Q a--- >--- > spliceFail :: Q Exp--- > spliceFail = fail "This splice fails"--- >--- > spliceInt :: Q Exp--- > spliceInt = [| 1 |]--- >--- > test1 :: Either String Int--- > test1 = $(recover' (pure . Left) $ Right <$> spliceFail) -- generates `Left "This splice fails"`--- >--- > test2 :: Either String Int--- > test2 = $(recover' (pure . Left) $ Right <$> spliceInt) -- generates `Right 1`------ But for now, we'll have to use 'tryQ':------ > test1 :: Either String Int--- > test1 = $(tryQ spliceFail) -- generates `Left "This splice fails"`--- >--- > test2 :: Either String Int--- > test2 = $(tryQ spliceInt) -- generates `Right 1`------ ref. https://ghc.haskell.org/trac/ghc/ticket/2340+import Language.Haskell.TH.TestUtils.QMode+import Language.Haskell.TH.TestUtils.QState -newtype TryQ a = TryQ { unTryQ :: ExceptT () (StateT (Maybe String) Q) a }-  deriving-    ( Functor-    , Applicative-    , Monad-#if MIN_VERSION_template_haskell(2,13,0)-    , MonadIO-#endif-    )+runTestQ :: forall mode a. IsMockedMode mode => QState mode -> Q a -> TestQResult mode a+runTestQ state = fmapResult' (either error id) . tryTestQ state+  where+    fmapResult' = fmapResult @mode @(Either String a) @a -liftQ :: Q a -> TryQ a-liftQ = TryQ . Trans.lift . Trans.lift+runTestQErr :: forall mode a. (IsMockedMode mode, Show a) => QState mode -> Q a -> TestQResult mode String+runTestQErr state = fmapResult' (either id (error . mkMsg)) . tryTestQ state+  where+    fmapResult' = fmapResult @mode @(Either String a) @String+    mkMsg a = "Unexpected success: " ++ show a -instance Fail.MonadFail TryQ where-  fail _ = TryQ $ throwE ()+tryTestQ :: forall mode a. IsMockedMode mode => QState mode -> Q a -> TestQResult mode (Either String a)+tryTestQ state = runResult @mode . runTestQMonad . runQ+  where+    runTestQMonad =+      Except.runExceptT+      . (`State.evalStateT` initialInternalState)+      . (`Reader.runReaderT` state)+      . unTestQ -instance Quasi TryQ where-  qNewName name = liftQ $ qNewName name+    initialInternalState = InternalState+      { lastErrorReport = Nothing+      , newNameCounter = 0+      } -  qReport False msg = liftQ $ qReport False msg-  qReport True msg = TryQ . Trans.lift . put $ Just msg+data InternalState = InternalState+  { lastErrorReport :: Maybe String+  , newNameCounter  :: Int+  } -  qRecover (TryQ handler) (TryQ action) = TryQ $ catchE action (const handler)-  qLookupName b name = liftQ $ qLookupName b name-  qReify name = liftQ $ qReify name-  qReifyFixity name = liftQ $ qReifyFixity name-  qReifyInstances name types = liftQ $ qReifyInstances name types-  qReifyRoles name = liftQ $ qReifyRoles name-  qReifyAnnotations ann = liftQ $ qReifyAnnotations ann-  qReifyModule m = liftQ $ qReifyModule m-  qReifyConStrictness name = liftQ $ qReifyConStrictness name-  qLocation = liftQ qLocation-  qRunIO m = liftQ $ qRunIO m-  qAddDependentFile fp = liftQ $ qAddDependentFile fp-  qAddTopDecls decs = liftQ $ qAddTopDecls decs-  qAddModFinalizer q = liftQ $ qAddModFinalizer q-  qGetQ = liftQ qGetQ-  qPutQ x = liftQ $ qPutQ x-  qIsExtEnabled ext = liftQ $ qIsExtEnabled ext-  qExtsEnabled = liftQ qExtsEnabled+newtype TestQ (mode :: MockedMode) a = TestQ+  { unTestQ+      :: Reader.ReaderT (QState mode)+          ( State.StateT InternalState+              ( Except.ExceptT String+                  Q+              )+          )+          a+  } deriving (Functor, Applicative, Monad) -#if MIN_VERSION_template_haskell(2,13,0)-  qAddCorePlugin s = liftQ $ qAddCorePlugin s-#endif+{- TestQ stack: ReaderT -} -#if MIN_VERSION_template_haskell(2,14,0)-  qAddTempFile s = liftQ $ qAddTempFile s-  qAddForeignFilePath lang s = liftQ $ qAddForeignFilePath lang s-#elif MIN_VERSION_template_haskell(2,12,0)-  qAddForeignFile lang s = liftQ $ qAddForeignFile lang s-#endif+getState :: TestQ mode (QState mode)+getState = TestQ Reader.ask -#if MIN_VERSION_template_haskell(2,16,0)-  qReifyType n = liftQ $ qReifyType n-#endif+getMode :: TestQ mode (QMode mode)+getMode = mode <$> getState --- | Run the given Template Haskell computation, returning either an error message or the final--- result.-tryQ' :: Q a -> Q (Either String a)-tryQ' = fmap cast . (`runStateT` Nothing) . runExceptT . unTryQ . runQ+lookupReifyInfo :: (ReifyInfo -> a) -> Name -> TestQ mode a+lookupReifyInfo f name = do+  QState{reifyInfo} <- getState+  case lookup name reifyInfo of+    Just info -> return $ f info+    Nothing -> error $ "Cannot reify " ++ show name ++ " (did you mean to add it to reifyInfo?)"++{- TestQ stack: StateT -}++getLastError :: TestQ mode (Maybe String)+getLastError = TestQ . lift $ State.gets lastErrorReport++storeLastError :: String -> TestQ mode ()+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 })++{- TestQ stack: ExceptT -}++throwError :: String -> TestQ mode a+throwError = TestQ . lift . lift . Except.throwE++catchError :: TestQ mode a -> (String -> TestQ mode a) -> TestQ mode a+catchError (TestQ action) handler = TestQ $ catchE' action (unTestQ . handler)   where-    cast (Left (), Nothing) = Left "Q monad failure"-    cast (Left (), Just msg) = Left msg-    cast (Right a, _) = Right a+    catchE' = Reader.liftCatch (State.liftCatch Except.catchE) --- | Run the given Template Haskell computation, returning a splicable expression that resolves--- to 'Left' the error message or 'Right' the final result.------ > -- Left "This splice fails"--- > $(tryQ spliceFail) :: Either String Int--- >--- > -- Right 1--- > $(tryQ spliceInt) :: Either String Int-tryQ :: Q Exp -> Q Exp-tryQ = tryQ' >=> either-  (appE (typeAppString [| Left |]) . lift)-  (appE (typeAppString [| Right |]) . pure)+{- TestQ stack: Q -} --- | 'tryQ', except returns 'Just' the error message or 'Nothing' if the computation succeeded.------ > -- Just "This splice fails"--- > $(tryQErr spliceFail) :: Maybe String--- >--- > -- Nothing--- > $(tryQErr spliceInt) :: Maybe String-tryQErr :: Q a -> Q Exp-tryQErr = tryQ' >=> either-  (appE (typeAppString [| Just |]) . lift)-  (const (typeAppString [| Nothing |]))+liftQ :: Q a -> TestQ mode a+liftQ = TestQ . lift . lift . lift --- | 'tryQ', except returns the error message or fails if the computation succeeded.------ > -- "This splice fails"--- > $(tryQErr' spliceFail) :: String--- >--- > -- compile time error: "Q monad unexpectedly succeeded"--- > $(tryQErr' spliceInt) :: String-tryQErr' :: Q a -> Q Exp-tryQErr' = tryQ' >=> either-  lift-  (const $ fail "Q monad unexpectedly succeeded")+{- Instances -} -{- Helpers -}+instance MonadIO (TestQ mode) where+  liftIO = liftQ . runIO -typeAppString :: Q Exp -> Q Exp-typeAppString expQ =-#if MIN_VERSION_template_haskell(2,12,0)-    TH.appTypeE expQ [t| String |]-#else-    expQ+instance MonadFail (TestQ mode) where+  fail msg = do+    -- The implementation of 'fail' for Q will send the message to qReport before calling 'fail'.+    -- Check to see if qReport put any message in the state and throw that message if so.+    lastMessage <- getLastError+    throwError $ fromMaybe msg lastMessage++-- | A helper to override Quasi methods when mocked and passthrough when not.+use :: Override mode a -> TestQ mode a+use Override{..} = do+  mode <- getMode+  case (mode, whenMocked) of+    (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+  }++data WhenMocked mode a+  = DoInstead (TestQ mode a)+  | Unsupported String++instance Quasi (TestQ mode) where+  {- 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 True msg = storeLastError msg++  {- Names -}++  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+    }++  {- ReifyInfo -}++  qReify name = use Override+    { whenAllowed = qReify name+    , whenMocked = DoInstead $ lookupReifyInfo reifyInfoInfo 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+    }++#if MIN_VERSION_template_haskell(2,16,0)+  qReifyType name = use Override+    { whenAllowed = qReifyType name+    , whenMocked = DoInstead $ lookupReifyInfo reifyInfoType name+    }+#endif++  {- 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
+ src/Language/Haskell/TH/TestUtils/QMode.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Language.Haskell.TH.TestUtils.QMode+  ( MockedMode(..)+  , QMode(..)+  , IsMockedMode(..)+  ) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift)+import System.IO.Unsafe (unsafePerformIO)++data MockedMode = FullyMocked | FullyMockedWithIO | NotMocked++class IsMockedMode (mode :: MockedMode) where+  type TestQResult mode a++  runResult :: Q a -> TestQResult mode a+  fmapResult :: (a -> b) -> TestQResult mode a -> TestQResult mode b++instance IsMockedMode 'FullyMocked where+  type TestQResult 'FullyMocked a = a+  runResult = unsafePerformIO . runQ+  fmapResult = ($)++instance IsMockedMode 'FullyMockedWithIO where+  type TestQResult 'FullyMockedWithIO a = IO a+  runResult = runQ+  fmapResult = fmap++instance IsMockedMode 'NotMocked where+  type TestQResult 'NotMocked a = Q a+  runResult = id+  fmapResult = fmap++{- Configuring TestQ -}++data QMode (mode :: MockedMode) where+  -- | All Q actions are mocked and IO actions are disallowed.+  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++deriving instance Show (QMode mode)+deriving instance Lift (QMode mode)
+ src/Language/Haskell/TH/TestUtils/QState.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++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(..))++-- | State information for mocking Q functionality.+data QState (mode :: MockedMode) = QState+  { 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)++data ReifyInfo = ReifyInfo+  { reifyInfoInfo   :: Info+  , reifyInfoFixity :: Maybe Fixity+  , reifyInfoRoles  :: Maybe [Role]+  , reifyInfoType   :: Type+  } deriving (Show, Lift)++-- | 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++  [| (name, ReifyInfo info fixity roles $infoType) |]++-- | A shortcut for defining an unmocked Q.+unmockedState :: QState 'NotMocked+unmockedState = QState+  { mode = AllowQ+  , knownNames = []+  , reifyInfo = []+  }
test/Main.hs view
@@ -1,37 +1,365 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -import Data.Void (Void)+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 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  main :: IO () main = defaultMain $ testGroup "th-test-utils"-  [ testFirstConstrForType-  , testExplode+  [ testAllowQ+  , testMockQ+  , testMockQAllowIO   ] -testFirstConstrForType :: TestTree-testFirstConstrForType = testGroup "firstConstrForType"-  [ testCase "tryQ Maybe" $-    $(tryQ $ firstConstrForType "Maybe") @?= (Right "Nothing" :: Either String String)-  , testCase "tryQErr Maybe" $-    $(tryQErr $ firstConstrForType "Maybe") @?= (Nothing :: Maybe String)-  , testCase "tryQ NonExistent" $-    $(tryQ $ firstConstrForType "NonExistent") @?= (Left "Type does not exist: NonExistent" :: Either String String)-  , testCase "tryQErr Show" $-    $(tryQErr $ firstConstrForType "Show") @?= Just "Not a data type: Show"-  , testCase "tryQErr' Void" $-    $(tryQErr' $ firstConstrForType "Void") @?= "Data type has no constructors: Void"+testAllowQ :: TestTree+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 ()+          ) -testExplode :: TestTree-testExplode = testGroup "explode"-  [ testCase "abc" $-    $(tryQ $ explode "abc") @?= (Right ["a", "b", "c"] :: Either String [String])-  , testCase "\"\"" $-    $(tryQ $ explode "") @?= (Left "Cannot explode empty string" :: Either String [String])+      -- 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+          )+      ]++testMockQ :: TestTree+testMockQ = testMockQ' MockQTests+  { qMode = MockQ+  , toIO = pure+  , qRunIOResult = \_ -> Left "IO actions not allowed"+  }++testMockQAllowIO :: TestTree+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+  , 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   ]+  where+    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+    runTestQ' state = forceM . toIO . runTestQ state++    -- Call runTestQ', capturing any 'error' calls that occur in evaluating the result+    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"+      ]++    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)] }++          nameShow <- runTestQ' state $ qLookupName True "Show"+          nameShow @?= Just ''Show++          nameEq <- runTestQ' state $ qLookupName True "Eq"+          nameEq @?= Nothing++          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++          qRunIOResult' <- runTestQWithErrors mockedState $ qRunIO io+          qRunIOResult' @?= 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+      ]++    -- force both MockQ and MockQAllowIO to resolve the same goldens+    golden name = goldenVsString name ("test/goldens/MockQ_" ++ name ++ ".golden")++    labelled :: Show a => [(String, IO a)] -> IO ByteString+    labelled vals = do+      let mkLine (label, getVal) = do+            val <- getVal+            return $ label ++ ": " ++ show val+      Char8.pack . intercalate "\n" . map (++ "\n") <$> mapM mkLine vals++    runUnsupported :: Show a => QState mode -> Q a -> IO ByteString+    runUnsupported state q = labelled [("Unsupported", runTestQWithErrors state q)]
test/TH.hs view
@@ -1,30 +1,54 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}  module TH where +import Control.Exception (SomeException, displayException, try)+import Data.Bifunctor (first) import Language.Haskell.TH-import Language.Haskell.TH.Syntax (lift)+import Language.Haskell.TH.Syntax (Module(..))+import Test.Tasty.HUnit (Assertion, testCase, (@?=)) -firstConstrForType :: String -> ExpQ-firstConstrForType typeName = lookupTypeName typeName >>= \case-  Nothing -> fail $ "Type does not exist: " ++ typeName-  Just name -> reify name >>= \case-#if MIN_VERSION_template_haskell(2,11,0)-    TyConI (DataD _ _ _ _ cons _) -> firstConstr cons-    TyConI (NewtypeD _ _ _ _ con _) -> firstConstr [con]-#else-    TyConI (DataD _ _ _ cons _) -> firstConstr cons-    TyConI (NewtypeD _ _ _ con _) -> firstConstr [con]-#endif-    _ -> fail $ "Not a data type: " ++ typeName+import Language.Haskell.TH.TestUtils (runTestQ, unmockedState)++-- | Run an HUnit assertion in a Template Haskell splice.+testCaseTH :: String -> Q Assertion -> ExpQ+testCaseTH testName q = do+  q >>= runIO+  [| testCase testName $ return () |]++-- | Check that the given action evalutes.+isSuccess :: Q a -> Q Assertion+isSuccess action = do+  _ <- forceM action+  return $ return ()++-- | Check that the given action results in the same thing in both Q and unmocked TestQ.+checkUnmockedMatches :: (Eq a, Show a) => Q a -> Q Assertion+checkUnmockedMatches action = do+  expected <- action+  actual <- runTestQ unmockedState action+  return $ actual @?= expected++-- | Capture any 'error' calls.+tryIO :: IO a -> IO (Either String a)+tryIO m = first showError <$> try m   where-    firstConstr [] = fail $ "Data type has no constructors: " ++ typeName-    firstConstr (c:_) = lift . nameBase =<< case c of-      NormalC name _ -> pure name-      RecC name _ -> pure name-      _ -> fail $ "Weird constructor: " ++ typeName+    -- strip out call stack+    showError = head . lines . displayException @SomeException -explode :: String -> ExpQ-explode [] = fail "Cannot explode empty string"-explode xs = listE $ map (litE . stringL . (:[])) xs+-- | Same as tryIO, except in the Q monad.+tryQ :: Q a -> Q (Either String a)+tryQ q = runIO . tryIO . forceM . pure =<< q++-- | Force the evaluation of @a@ when the monadic action is evaluated.+forceM :: Monad m => m a -> m a+forceM m = do+  a <- m+  a `seq` return a++thisModule :: ExpQ+thisModule = do+  Module pkgName modName <- Language.Haskell.TH.thisModule+  -- if only Module had a Lift instance+  [| Module pkgName modName |]
+ test/TestLib.hs view
@@ -0,0 +1,11 @@+module TestLib where++import Language.Haskell.TH++{-# ANN basicSuccess "This is a test annotation" #-}++basicSuccess :: Q String+basicSuccess = return "Success"++basicFailure :: Q String+basicFailure = fail "Failure"
th-test-utils.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: efd2801696db16775e89093ddef200e5d3b5d09c77563a404db58f82f6a8841e+-- hash: 2ec6fa51cea97a219a17187389530388c5e93cfe52e0ae659b249dbb68a5171b  name:           th-test-utils-version:        1.0.2+version:        1.1.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.@@ -30,6 +30,8 @@ library   exposed-modules:       Language.Haskell.TH.TestUtils+      Language.Haskell.TH.TestUtils.QMode+      Language.Haskell.TH.TestUtils.QState   other-modules:       Paths_th_test_utils   hs-source-dirs:@@ -38,6 +40,7 @@   build-depends:       base >=4.9 && <5     , template-haskell >=2.11.1.0 && <2.17+    , th-orphans >=0.13.4 && <0.13.11     , transformers >=0.5.2 && <0.5.7   if impl(ghc >= 8.0)     ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances@@ -49,6 +52,7 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      TestLib       TH       Paths_th_test_utils   hs-source-dirs:@@ -56,9 +60,12 @@   ghc-options: -Wall   build-depends:       base >=4.9 && <5-    , tasty >=0.11.3 && <1.4-    , tasty-hunit >=0.9.2 && <0.10.1+    , bytestring+    , tasty+    , tasty-golden+    , tasty-hunit     , template-haskell >=2.11.1.0 && <2.17+    , th-orphans >=0.13.4 && <0.13.11     , th-test-utils     , transformers >=0.5.2 && <0.5.7   if impl(ghc >= 8.0)