-- |
-- 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 :: a
didNotRunPluginError = a -> a
forall a. a -> a
lazy ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: Obligation -> Q Exp
inspectTest Obligation
obl = do
#if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)
    [Char] -> Q ()
addCorePlugin [Char]
"Test.Tasty.Inspection.Plugin"
#endif
    [Char]
nameS   <- Q [Char]
genName
    Name
name    <- [Char] -> Q Name
forall (q :: * -> *). Quasi q => [Char] -> q Name
newUniqueName [Char]
nameS
    Exp
annExpr <- Obligation -> Q Exp
forall a. Data a => a -> Q Exp
liftData Obligation
obl
    [Dec] -> Q ()
addTopDecls ([Dec] -> Q ()) -> [Dec] -> Q ()
forall a b. (a -> b) -> a -> b
$
        [ Name -> Type -> Dec
SigD Name
name (Name -> Type
ConT ''CheckResult)
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
name) (Exp -> Body
NormalB (Name -> Exp
VarE 'didNotRunPluginError)) []
        , Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
name Inline
NoInline RuleMatch
FunLike Phases
AllPhases)
        , Pragma -> Dec
PragmaD (AnnTarget -> Exp -> Pragma
AnnP (Name -> AnnTarget
ValueAnnotation Name
name) Exp
annExpr)
        ]
    Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
      Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'SingleTest) (Lit -> Exp
LitE ([Char] -> Lit
StringL (Obligation -> [Char]
prettyObligation Obligation
obl)))) (Name -> Exp
VarE Name
name)
  where
    genName :: Q [Char]
genName = do
        (Int
r, Int
c) <- Loc -> (Int, Int)
loc_start (Loc -> (Int, Int)) -> Q Loc -> Q (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
        [Char] -> Q [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Q [Char]) -> [Char] -> Q [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"inspect_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
r [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
c

prettyObligation :: Obligation -> String
prettyObligation :: Obligation -> [Char]
prettyObligation Obligation{Bool
Maybe [Char]
Maybe Loc
Name
Property
target :: Obligation -> Name
property :: Obligation -> Property
expectFail :: Obligation -> Bool
srcLoc :: Obligation -> Maybe Loc
storeResult :: Obligation -> Maybe [Char]
storeResult :: Maybe [Char]
srcLoc :: Maybe Loc
expectFail :: Bool
testName :: Maybe [Char]
property :: Property
target :: Name
testName :: Obligation -> Maybe [Char]
..} = case Maybe [Char]
testName of
  Just [Char]
n -> [Char]
n
  Maybe [Char]
Nothing -> (Name -> [Char]) -> Name -> Property -> [Char]
prettyProperty Name -> [Char]
showTHName Name
target Property
property

showTHName :: Name -> String
showTHName :: Name -> [Char]
showTHName (Name OccName
occ NameFlavour
_) = OccName -> [Char]
occString OccName
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 :: [Char] -> q Name
newUniqueName [Char]
str = do
  Name
n <- [Char] -> q Name
forall (q :: * -> *). Quasi q => [Char] -> q Name
qNewName [Char]
str
  [Char] -> q Name
forall (q :: * -> *). Quasi q => [Char] -> q Name
qNewName ([Char] -> q Name) -> [Char] -> q Name
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Show a => a -> [Char]
show Name
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 :: Name -> [Name] -> Obligation
hasNoTypes Name
n [Name]
ts = Name -> Property -> Obligation
mkObligation Name
n ([Name] -> Property
NoTypes [Name]
ts)

-- | Declare that given entities do not occur in a function’s implementation.
doesNotUseAnyOf :: Name -> [Name] -> Obligation
doesNotUseAnyOf :: Name -> [Name] -> Obligation
doesNotUseAnyOf Name
n [Name]
ns = Name -> Property -> Obligation
mkObligation Name
n ([Name] -> Property
NoUseOf [Name]
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 :: [Name -> Obligation] -> Name -> Q Exp
inspectObligations [Name -> Obligation]
obls Name
name = do
  [Exp]
exps <- ((Name -> Obligation) -> Q Exp) -> [Name -> Obligation] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Obligation -> Q Exp
inspectTest (Obligation -> Q Exp)
-> ((Name -> Obligation) -> Obligation)
-> (Name -> Obligation)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Obligation -> Obligation
inscribeTestName (Obligation -> Obligation)
-> ((Name -> Obligation) -> Obligation)
-> (Name -> Obligation)
-> Obligation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name -> Obligation) -> Name -> Obligation
forall a b. (a -> b) -> a -> b
$ Name
name)) [Name -> Obligation]
obls
  Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'TestGroup) (Lit -> Exp
LitE ([Char] -> Lit
StringL (Name -> [Char]
showTHName Name
name)))) ([Exp] -> Exp
ListE [Exp]
exps)
  where
    showTHName' :: Name -> [Char]
showTHName' Name
n = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name then [Char]
forall a. Monoid a => a
mempty else Name -> [Char]
showTHName Name
n
    inscribeTestName :: Obligation -> Obligation
inscribeTestName obl :: Obligation
obl@Obligation{Bool
Maybe [Char]
Maybe Loc
Name
Property
storeResult :: Maybe [Char]
srcLoc :: Maybe Loc
expectFail :: Bool
testName :: Maybe [Char]
property :: Property
target :: Name
target :: Obligation -> Name
property :: Obligation -> Property
expectFail :: Obligation -> Bool
srcLoc :: Obligation -> Maybe Loc
storeResult :: Obligation -> Maybe [Char]
testName :: Obligation -> Maybe [Char]
..} = case Maybe [Char]
testName of
      Just{}  -> Obligation
obl
      Maybe [Char]
Nothing -> Obligation
obl { testName :: Maybe [Char]
testName = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
        (Name -> [Char]) -> Name -> Property -> [Char]
prettyProperty Name -> [Char]
showTHName' Name
target Property
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 :: (Name -> Obligation) -> [Name] -> Q Exp
inspectNames Name -> Obligation
_ [] =
  Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'TestGroup) (Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
"<empty>"))) ([Exp] -> Exp
ListE [])
inspectNames Name -> Obligation
obl names :: [Name]
names@(Name
name : [Name]
_) = do
  [Exp]
exps <- (Name -> Q Exp) -> [Name] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Name
n -> Obligation -> Q Exp
inspectTest (Obligation -> Q Exp) -> Obligation -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Obligation -> Obligation
forceTestName Name
n (Obligation -> Obligation) -> Obligation -> Obligation
forall a b. (a -> b) -> a -> b
$ Name -> Obligation
obl Name
n) [Name]
names
  Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'TestGroup) (Lit -> Exp
LitE ([Char] -> Lit
StringL [Char]
groupName))) ([Exp] -> Exp
ListE [Exp]
exps)
  where
    forceTestName :: Name -> Obligation -> Obligation
forceTestName Name
n Obligation
o = case Obligation -> Maybe [Char]
testName Obligation
o of
        Just{}  -> Obligation
o
        Maybe [Char]
Nothing -> Obligation
o { testName :: Maybe [Char]
testName = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
showTHName Name
n }
    showTHName' :: Name -> [Char]
showTHName' Name
n = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name then [Char]
forall a. Monoid a => a
mempty else Name -> [Char]
showTHName Name
n
    firstObl :: Obligation
firstObl = Name -> Obligation
obl Name
name
    groupName :: [Char]
groupName = case Obligation -> Maybe [Char]
testName Obligation
firstObl of
      Just [Char]
n -> [Char]
n
      Maybe [Char]
Nothing -> (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
        (Name -> [Char]) -> Name -> Property -> [Char]
prettyProperty Name -> [Char]
showTHName' (Obligation -> Name
target Obligation
firstObl) (Obligation -> Property
property Obligation
firstObl)