{-# LANGUAGE TemplateHaskell #-}
module Test.Tasty.TH
( testGroupGenerator
, defaultMainGenerator
, testGroupGeneratorFor
, defaultMainGeneratorFor
, extractTestFunctions
, locationModule
) where
import Control.Monad (join)
import Control.Applicative
import Language.Haskell.Exts (parseFileContentsWithMode)
import Language.Haskell.Exts.Parser (ParseResult(..), defaultParseMode, parseFilename)
import qualified Language.Haskell.Exts.Syntax as S
import Language.Haskell.TH
import Data.Maybe
import Data.Data (gmapQ, Data)
import Data.Typeable (cast)
import Data.List (nub, isPrefixOf, find)
import qualified Data.Foldable as F
import Test.Tasty
import Prelude
defaultMainGenerator :: ExpQ
defaultMainGenerator :: ExpQ
defaultMainGenerator = [| defaultMain $(testGroupGenerator) |]
testGroupGenerator :: ExpQ
testGroupGenerator :: ExpQ
testGroupGenerator = Q ExpQ -> ExpQ
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q ExpQ -> ExpQ) -> Q ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ExpQ
testGroupGeneratorFor (String -> [String] -> ExpQ) -> Q String -> Q ([String] -> ExpQ)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> String
loc_module Q Loc
location Q ([String] -> ExpQ) -> Q [String] -> Q ExpQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [String]
testFunctions
where
testFunctions :: Q [String]
testFunctions = Q Loc
location Q Loc -> (Loc -> Q [String]) -> Q [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [String] -> Q [String]
forall a. IO a -> Q a
runIO (IO [String] -> Q [String])
-> (Loc -> IO [String]) -> Loc -> Q [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [String]
extractTestFunctions (String -> IO [String]) -> (Loc -> String) -> Loc -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_filename
extractTestFunctions :: FilePath -> IO [String]
String
filePath = do
String
file <- String -> IO String
readFile String
filePath
let functions :: [String]
functions = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe (String -> [String]
lexed String
file) (String -> Maybe [String]
parsed String
file)
filtered :: String -> [String]
filtered String
pat = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
pat String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
functions
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String])
-> ([String] -> [String]) -> [String] -> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String -> [String]
filtered String
"prop_", String -> [String]
filtered String
"case_", String -> [String]
filtered String
"test_"]
where
lexed :: String -> [String]
lexed = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst ([(String, String)] -> [String])
-> (String -> [(String, String)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [(String, String)]) -> [String] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [(String, String)]
lex ([String] -> [(String, String)])
-> (String -> [String]) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
parsed :: String -> Maybe [String]
parsed String
file = case ParseMode -> String -> ParseResult (Module SrcSpanInfo)
parseFileContentsWithMode (ParseMode
defaultParseMode { parseFilename :: String
parseFilename = String
filePath }) String
file of
ParseOk Module SrcSpanInfo
parsedModule -> [String] -> Maybe [String]
forall a. a -> Maybe a
Just (Module SrcSpanInfo -> [String]
forall {l}. Data l => Module l -> [String]
declarations Module SrcSpanInfo
parsedModule)
ParseFailed SrcLoc
_ String
_ -> Maybe [String]
forall a. Maybe a
Nothing
declarations :: Module l -> [String]
declarations (S.Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
decls) = (Decl l -> [String]) -> [Decl l] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl l -> [String]
forall {l}. Data l => Decl l -> [String]
testFunName [Decl l]
decls
declarations Module l
_ = []
testFunName :: Decl l -> [String]
testFunName (S.PatBind l
_ Pat l
pat Rhs l
_ Maybe (Binds l)
_) = Pat l -> [String]
forall l. Data l => Pat l -> [String]
patternVariables Pat l
pat
testFunName (S.FunBind l
_ [Match l]
clauses) = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub ((Match l -> String) -> [Match l] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Match l -> String
forall {l}. Match l -> String
clauseName [Match l]
clauses)
testFunName Decl l
_ = []
clauseName :: Match l -> String
clauseName (S.Match l
_ Name l
name [Pat l]
_ Rhs l
_ Maybe (Binds l)
_) = Name l -> String
forall l. Name l -> String
nameString Name l
name
clauseName (S.InfixMatch l
_ Pat l
_ Name l
name [Pat l]
_ Rhs l
_ Maybe (Binds l)
_) = Name l -> String
forall l. Name l -> String
nameString Name l
name
nameString :: S.Name l -> String
nameString :: forall l. Name l -> String
nameString (S.Ident l
_ String
n) = String
n
nameString (S.Symbol l
_ String
n) = String
n
patternVariables :: Data l => S.Pat l -> [String]
patternVariables :: forall l. Data l => Pat l -> [String]
patternVariables = Pat l -> [String]
forall l. Data l => Pat l -> [String]
go
where
go :: Pat l -> [String]
go (S.PVar l
_ Name l
name) = [Name l -> String
forall l. Name l -> String
nameString Name l
name]
go Pat l
pat = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> [String]) -> Pat l -> [[String]]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((Pat l -> [String]) -> Maybe (Pat l) -> [String]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Pat l -> [String]
go (Maybe (Pat l) -> [String])
-> (d -> Maybe (Pat l)) -> d -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Maybe (Pat l)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast) Pat l
pat
locationModule :: ExpQ
locationModule :: ExpQ
locationModule = do
Loc
loc <- Q Loc
location
Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Loc -> String
loc_module Loc
loc
testGroupGeneratorFor
:: String
-> [String]
-> ExpQ
testGroupGeneratorFor :: String -> [String] -> ExpQ
testGroupGeneratorFor String
name [String]
functionNames = [| testGroup name $(listE (mapMaybe test functionNames)) |]
where
testFunctions :: [(String, String)]
testFunctions = [(String
"prop_", String
"testProperty"), (String
"case_", String
"testCase"), (String
"test_", String
"testGroup")]
getTestFunction :: String -> Maybe String
getTestFunction String
fname = (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> Maybe (String, String) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, String) -> Bool)
-> [(String, String)] -> Maybe (String, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
fname) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
testFunctions
test :: String -> Maybe (m Exp)
test String
fname = do
String
fn <- String -> Maybe String
getTestFunction String
fname
m Exp -> Maybe (m Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (m Exp -> Maybe (m Exp)) -> m Exp -> Maybe (m Exp)
forall a b. (a -> b) -> a -> b
$ m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> m Exp) -> Name -> m Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
fn) (String -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> String
fixName String
fname))) (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
fname))
defaultMainGeneratorFor
:: String
-> [String]
-> ExpQ
defaultMainGeneratorFor :: String -> [String] -> ExpQ
defaultMainGeneratorFor String
name [String]
fns = [| defaultMain $(testGroupGeneratorFor name fns) |]
fixName :: String -> String
fixName :: String -> String
fixName = Char -> Char -> String -> String
forall a. Eq a => a -> a -> [a] -> [a]
replace Char
'_' Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
tail (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
replace :: Eq a => a -> a -> [a] -> [a]
replace :: forall a. Eq a => a -> a -> [a] -> [a]
replace a
b a
v = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
i -> if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i then a
v else a
i)