tasty-inspection-testing-0.2: src/Test/Tasty/Inspection.hs

-- |
-- Module:      Test.Tasty.Inspection
-- Copyright:   (c) 2017 Joachim Breitner, 2021 Andrew Lelechenko
-- Licence:     MIT
-- Maintainer:  andrew.lelechenko@gmail.com
--
-- Integrate @inspection-testing@ into @tasty@ test suites.
--

{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Tasty.Inspection
  ( inspectTest
  , inspectObligations
  , inspectNames
  -- * Obligations
  -- | Mostly reexported from "Test.Inspection".
  , Obligation(testName)
  , mkObligation
  , Property(..)
  , (===)
  , (==-)
#if MIN_VERSION_inspection_testing(0,5,0)
  , (==~)
#endif
  , hasNoType
  , hasNoTypes
  , hasNoGenerics
  , hasNoTypeClasses
  , hasNoTypeClassesExcept
  , doesNotUse
  , doesNotUseAnyOf
  , coreOf
  ) where

import GHC.Exts (lazy)
import Language.Haskell.TH (Q, Dec(..), Exp(..), Lit(..), Phases(..), RuleMatch(..), Inline(..), Pragma(..), Body(..), Pat(..), Type(..), AnnTarget(..), Name, loc_start, location)
import Language.Haskell.TH.Syntax (Quasi(qNewName), liftData, addTopDecls, Name(..), occString)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)
import Language.Haskell.TH.Syntax (addCorePlugin)
#endif

import Test.Tasty.Runners (TestTree(..))
import Test.Inspection (Obligation(..), testName, mkObligation, Property(..), (===), (==-), hasNoType, hasNoGenerics, hasNoTypeClasses, hasNoTypeClassesExcept, doesNotUse, coreOf)
#if MIN_VERSION_inspection_testing(0,5,0)
import Test.Inspection ((==~))
#endif
import Test.Inspection.Plugin (prettyProperty)
import Test.Tasty.Inspection.Internal (CheckResult)

didNotRunPluginError :: a
didNotRunPluginError = lazy (error "Test.Tasty.Inspection.Plugin did not run")
{-# NOINLINE didNotRunPluginError #-}

-- | Create a @tasty@ 'TestTree' from an 'Obligation':
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > {-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}
-- >
-- > import Test.Tasty
-- > import Test.Tasty.Inspection
-- >
-- > lhs :: (a -> b) -> Maybe a -> Bool
-- > lhs f x = case fmap f x of
-- >   Nothing -> True
-- >   Just{}  -> False
-- >
-- > rhs :: (a -> b) -> Maybe a -> Bool
-- > rhs _ Nothing = True
-- > rhs _ Just{}  = False
-- >
-- > main :: IO ()
-- > main = defaultMain $(inspectTest $ 'lhs === 'rhs)
--
-- This is not the same function as 'Test.Inspection.inspectTest':
-- both return 'Q' 'Exp', but this one represents 'TestTree'
-- instead of 'Test.Inspection.Result'.
--
-- If you are unhappy with an autogenerated test name,
-- amend it using 'testName':
--
-- > inspectTest (obl { testName = Just "foo" })
--
-- To invert an obligation apply 'Test.Tasty.ExpectedFailure.expectFail'.
--
inspectTest :: Obligation -> Q Exp
inspectTest obl = do
#if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)
    addCorePlugin "Test.Tasty.Inspection.Plugin"
#endif
    nameS   <- genName
    name    <- newUniqueName nameS
    annExpr <- liftData obl
    addTopDecls $
        [ SigD name (ConT ''CheckResult)
        , ValD (VarP name) (NormalB (VarE 'didNotRunPluginError)) []
        , PragmaD (InlineP name NoInline FunLike AllPhases)
        , PragmaD (AnnP (ValueAnnotation name) annExpr)
        ]
    pure $
      AppE (AppE (ConE 'SingleTest) (LitE (StringL (prettyObligation obl)))) (VarE name)
  where
    genName = do
        (r, c) <- loc_start <$> location
        pure $ "inspect_" ++ show r ++ "_" ++ show c

prettyObligation :: Obligation -> String
prettyObligation Obligation{..} = case testName of
  Just n -> n
  Nothing -> prettyProperty showTHName target property

showTHName :: Name -> String
showTHName (Name occ _) = occString occ

-- | Like newName, but even more unique (unique across different splices),
-- and with unique @nameBase@s. Precondition: the string is a valid Haskell
-- alphanumeric identifier (could be upper- or lower-case).
newUniqueName :: Quasi q => String -> q Name
newUniqueName str = do
  n <- qNewName str
  qNewName $ show n
-- This is from https://ghc.haskell.org/trac/ghc/ticket/13054#comment:1

-- | Declare that given types do not occur in a function’s implementation.
hasNoTypes :: Name -> [Name] -> Obligation
hasNoTypes n ts = mkObligation n (NoTypes ts)

-- | Declare that given entities do not occur in a function’s implementation.
doesNotUseAnyOf :: Name -> [Name] -> Obligation
doesNotUseAnyOf n ns = mkObligation n (NoUseOf ns)

-- | Create a @tasty@ 'TestTree', which tests several 'Obligation's
-- for the same 'Name', generating a 'Test.Tasty.testGroup'.
inspectObligations :: [Name -> Obligation] -> Name -> Q Exp
inspectObligations obls name = do
  exps <- traverse (inspectTest . inscribeTestName . ($ name)) obls
  pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL (showTHName name)))) (ListE exps)
  where
    showTHName' n = if n == name then mempty else showTHName n
    inscribeTestName obl@Obligation{..} = case testName of
      Just{}  -> obl
      Nothing -> obl { testName = Just $ dropWhile (== ' ') $
        prettyProperty showTHName' target property }

-- | Create a @tasty@ 'TestTree', which tests an 'Obligation'
-- for several 'Name's, generating a 'Test.Tasty.testGroup'.
inspectNames :: (Name -> Obligation) -> [Name] -> Q Exp
inspectNames _ [] =
  pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL "<empty>"))) (ListE [])
inspectNames obl names@(name : _) = do
  exps <- traverse (\n -> inspectTest $ forceTestName n $ obl n) names
  pure $ AppE (AppE (ConE 'TestGroup) (LitE (StringL groupName))) (ListE exps)
  where
    forceTestName n o = case testName o of
        Just{}  -> o
        Nothing -> o { testName = Just $ showTHName n }
    showTHName' n = if n == name then mempty else showTHName n
    firstObl = obl name
    groupName = case testName firstObl of
      Just n -> n
      Nothing -> dropWhile (== ' ') $
        prettyProperty showTHName' (target firstObl) (property firstObl)