Expect Pattern Template Haskell assertion for HUnit / Hspec

THPlayground.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module THPlayground where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import qualified Test.HUnit.Lang

expectPatternTH :: Q Pat -> Q Exp
expectPatternTH qpat = do
  expectPatternTH' qpat [| pure () |]

expectPatternTH' :: Q Pat -> Q Exp -> Q Exp
expectPatternTH' qpat qout = do
  ppat <- fmap pprint qpat
  [| \x ->
        case x of
          $(qpat) -> $(qout)
          _ -> do
            Test.HUnit.Lang.assertFailure
              ( "Failed to match pattern; expected: { "
                  <> $(lift ppat)
                  <> " }; got: " <> show x
              )
    |]

THPlayground.Main.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module THPlayground.Main where

import Control.Exception
import Data.Function
import THPlayground
import Test.HUnit.Lang
import Test.Hspec

data Foo = Foo'Bar Bar | Foo'Baz Baz deriving stock (Show, Eq)
newtype Bar = Bar { bar :: Int } deriving stock (Show, Eq)
data Baz = Baz { spam :: Char, eggs :: Bool } deriving stock (Show, Eq)

main :: IO ()
main = hspec do
  describe "expectPatternTH" do
    it "wild underscore" do
      Foo'Bar Bar { bar = 1 } & $(expectPatternTH [p| Foo'Bar (Bar _) |])
    it "wild braces" do
      Foo'Bar Bar { bar = 1 } & $(expectPatternTH [p| Foo'Bar Bar {} |])
    it "wild field" do
      Foo'Bar Bar { bar = 1 } & $(expectPatternTH [p| Foo'Bar Bar { bar = _ } |])
    it "field value" do
      Foo'Bar Bar { bar = 1 } & $(expectPatternTH [p| Foo'Bar Bar { bar = 1 } |])
    it "throws" do
      x <- try @HUnitFailure $ Foo'Bar Bar { bar = 1 } & $(expectPatternTH [p| Foo'Baz _ |])
      msg <- x & $(expectPatternTH' [p| Left (HUnitFailure _ (Reason msg)) |] [| pure msg |])
      msg `shouldBe` "Failed to match pattern; expected: { THPlayground.Main.Foo'Baz _ }; got: Foo'Bar (Bar {bar = 1})"

  describe "expectPatternTH'" do
    it "does more" do
      Foo'Baz Baz { spam = 'a', eggs = True } & $(expectPatternTH' [p| Foo'Baz baz |]
        [| do
            spam baz `shouldBe` 'a'
            eggs baz `shouldBe` True
         |])
    it "returns" do
      baz <- Foo'Baz Baz { spam = 'a', eggs = True } & $(expectPatternTH' [p| Foo'Baz baz |] [| pure baz |])
      baz `shouldBe` Baz { spam = 'a', eggs = True }