Auto.hs

module Test.Tasty.Auto (findTests, showTestDriver) where

import Data.Function (on)
import Data.List (find, isPrefixOf, isSuffixOf, nub, intersperse, groupBy, sortOn, dropWhileEnd)
import Data.Maybe (fromJust)
import System.Directory (getDirectoryContents, doesDirectoryExist)
import Data.Traversable (for)
import System.FilePath ((</>), takeDirectory, pathSeparator, dropExtension)
import Data.Monoid (Endo(..))
import Data.Foldable (fold)

data Generator = Generator
  { genPrefix :: String
  , genImport, genClass :: ShowS
  , genSetup :: Test -> ShowS }

data Test = Test { testModule, testFunction :: String }

str :: String -> ShowS
str = (++)

sp, nl :: ShowS
sp = (' ':)
nl = ('\n':)

tr :: Char -> Char -> String -> String
tr a b = map $ \c -> if c == a then b else c

name, fn :: Test -> ShowS
name = shows . tr '_' ' ' . tail . dropWhile (/= '_') . testFunction
fn t = str (testModule t) . ('.':) . str (testFunction t)

generators :: [Generator]
generators =
  [ Generator { genPrefix = "prop_"
              , genImport = str "import qualified Test.Tasty.QuickCheck as QC\n"
              , genClass  = id
              , genSetup  = \t -> str "pure $ QC.testProperty " . name t . sp . fn t }
  , Generator { genPrefix = "scprop_"
              , genImport = str "import qualified Test.Tasty.SmallCheck as SC\n"
              , genClass  = id
              , genSetup  = \t -> str "pure $ SC.testProperty " . name t . sp . fn t }
  , Generator { genPrefix = "case_"
              , genImport = str "import qualified Test.Tasty.HUnit as HU\n"
              , genClass  = str "class TestCase a where testCase :: String -> a -> IO T.TestTree\n\
                                \instance TestCase (IO ())                      where testCase n = pure . HU.testCase      n\n\
                                \instance TestCase (IO String)                  where testCase n = pure . HU.testCaseInfo  n\n\
                                \instance TestCase ((String -> IO ()) -> IO ()) where testCase n = pure . HU.testCaseSteps n\n"
              , genSetup  = \t -> str "testCase " . name t . sp . fn t }
  , Generator { genPrefix = "spec_"
              , genImport = str "import qualified Test.Tasty.Hspec as HS\n"
              , genClass  = id
              , genSetup  = \t -> str "HS.testSpec " . name t . sp . fn t }
  , Generator { genPrefix = "test_"
              , genImport = id
              , genClass  = str "class TestGroup a where testGroup :: String -> a -> IO T.TestTree\n\
                                \instance TestGroup T.TestTree        where testGroup _ a = pure a\n\
                                \instance TestGroup [T.TestTree]      where testGroup n a = pure $ T.testGroup n a\n\
                                \instance TestGroup (IO T.TestTree)   where testGroup _ a = a\n\
                                \instance TestGroup (IO [T.TestTree]) where testGroup n a = T.testGroup n <$> a\n"
              , genSetup  = \t -> str "testGroup " . name t . sp . fn t } ]

testFileSuffixes :: [String]
testFileSuffixes = (++) <$> ["Spec", "Test"] <*> [".lhs", ".hs"]

getGenerator :: Test -> Generator
getGenerator t = fromJust $ find ((`isPrefixOf` testFunction t) . genPrefix) generators

getGenerators :: [Test] -> [Generator]
getGenerators = map head . groupBy  ((==) `on` genPrefix) . sortOn genPrefix . map getGenerator

showImports :: [String] -> ShowS
showImports = foldEndo . map (\m -> str "import qualified " . str m . nl) . nub

showSetup :: Test -> ShowS -> ShowS
showSetup t var = str "  " . var . str " <- " . genSetup (getGenerator t) t . nl

foldEndo :: (Functor f, Foldable f) => f (a -> a) -> (a -> a)
foldEndo = appEndo . fold . fmap Endo

ingredientImport :: String -> String
ingredientImport = init . dropWhileEnd (/= '.')

ingredients :: [String] -> ShowS
ingredients is = foldEndo (map (\i -> str i . (':':)) is) . str "T.defaultIngredients"

showTestDriver :: String -> [String] -> FilePath -> [Test] -> ShowS
showTestDriver modname is src ts =
  let gs = getGenerators ts; vars = map (str . ('t':) . show) [(0::Int)..] in
    str "{-# LINE 1 " . shows src . str " #-}\n\
        \{-# LANGUAGE FlexibleInstances #-}\n\
        \module " . str modname . str " (main, ingredients, tests) where\n\
        \import Prelude\n\
        \import qualified Test.Tasty as T\n\
        \import qualified Test.Tasty.Ingredients as T\n"
  . foldEndo (map genImport gs)
  . showImports (map ingredientImport is ++ map testModule ts)
  . foldEndo (map genClass gs)
  . str "tests :: IO T.TestTree\n\
        \tests = do\n"
  . foldEndo (zipWith showSetup ts vars)
  . str "  pure $ T.testGroup " . shows src . str " ["
  . foldEndo (intersperse (',':) $ zipWith (curry snd) ts vars)
  . str "]\n"
  . str "ingredients :: [T.Ingredient]\n\
        \ingredients = " . ingredients is . str "\n\
        \main :: IO ()\n\
        \main = tests >>= T.defaultMainWithIngredients ingredients\n"

filesBySuffix :: FilePath -> [String] -> IO [FilePath]
filesBySuffix dir suffixes = do
  entries <- filter (\s -> head s /= '.') <$> getDirectoryContents dir
  found <- for entries $ \entry -> do
    let dir' = dir </> entry
    exists <- doesDirectoryExist dir'
    if exists then map (entry </>) <$> filesBySuffix dir' suffixes else pure []
  pure $ filter (\x -> any (`isSuffixOf` x) suffixes) entries ++ concat found

findTests :: FilePath -> IO [Test]
findTests src = do
  let dir = takeDirectory src
  files <- filesBySuffix dir testFileSuffixes
  concat <$> traverse (\f -> extractTests f <$> readFile (dir </> f)) files

mkTest :: FilePath -> String -> Test
mkTest = Test . tr pathSeparator '.' . dropExtension

extractTests :: FilePath -> String -> [Test]
extractTests file =
    map (mkTest file) . nub
  . filter (\n -> any ((`isPrefixOf` n) . genPrefix) generators)
  . map fst . concatMap lex . lines