{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Test.Tasty.Inspection
( inspectTest
, inspectObligations
, inspectNames
, 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 #-}
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
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
hasNoTypes :: Name -> [Name] -> Obligation
hasNoTypes :: Name -> [Name] -> Obligation
hasNoTypes Name
n [Name]
ts = Name -> Property -> Obligation
mkObligation Name
n ([Name] -> Property
NoTypes [Name]
ts)
doesNotUseAnyOf :: Name -> [Name] -> Obligation
doesNotUseAnyOf :: Name -> [Name] -> Obligation
doesNotUseAnyOf Name
n [Name]
ns = Name -> Property -> Obligation
mkObligation Name
n ([Name] -> Property
NoUseOf [Name]
ns)
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 }
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)