tasty-autocollect-0.4.2: test/Test/Tasty/AutoCollect/GenerateMainTest.hs
{- AUTOCOLLECT.TEST -}
{-# LANGUAGE OverloadedStrings #-}
module Test.Tasty.AutoCollect.GenerateMainTest (
{- AUTOCOLLECT.TEST.export -}
) where
import Data.ByteString qualified as ByteString
import Data.Text (Text)
import Data.Text qualified as Text
import System.FilePath ((</>))
import Test.Predicates
import Test.Predicates.HUnit
import Test.Tasty.HUnit
import TestUtils.Golden
import TestUtils.Integration
import TestUtils.Predicates
test =
testCase "allows omitting all configuration" $
assertSuccess_ $
runMain ["{- AUTOCOLLECT.MAIN -}"]
test = testCase "searches recursively" $ do
(stdout, _) <-
assertSuccess . runMainWith (addFiles [("A/B/C/X/Y/Z.hs", testFile)]) $
[ "{- AUTOCOLLECT.MAIN"
, "group_type = modules"
, "-}"
]
getTestLines stdout @?~ containsStripped (eq "A.B.C.X.Y.Z")
where
testFile =
[ "{- AUTOCOLLECT.TEST -}"
, "module A.B.C.X.Y.Z where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test\" $ pure ()"
]
test =
testCase "ignores binary files" $
assertSuccess_ $
runMainWith
( \proj ->
proj
{ preRunCallback = \tmpdir ->
ByteString.writeFile
(tmpdir </> "binary-file")
(ByteString.pack [0 ..])
}
)
["{- AUTOCOLLECT.MAIN -}"]
test =
testCase "ignores directories with invalid module name" $
assertSuccess_ . runMainWith (addFiles [("A/&Bad/Foo.hs", ["{- AUTOCOLLECT.TEST -}"])]) $
["{- AUTOCOLLECT.MAIN -}"]
test =
testCase "ignores files with invalid module name" $
assertSuccess_ . runMainWith (addFiles [("A/#Foo#.hs", ["{- AUTOCOLLECT.TEST -}"])]) $
["{- AUTOCOLLECT.MAIN -}"]
test_batch =
[ testGolden
("output for group_type = " <> groupType <> " is as expected")
("output_group_type_" <> groupType <> ".golden")
$ fmap (normalizeTestOutput . fst) . assertSuccess . runMainWith (setTestFiles testFiles)
$ [ "{- AUTOCOLLECT.MAIN"
, "group_type = " <> Text.pack groupType
, "-}"
]
| groupType <- ["flat", "modules", "tree"]
]
where
testFiles =
[ ("MyProject/Test/A.hs", testFile "MyProject.Test.A" "A")
, ("MyProject/Test/A/X.hs", testFile "MyProject.Test.A.X" "AX")
, ("MyProject/Test/A/Y.hs", testFile "MyProject.Test.A.Y" "AY")
, ("MyProject/Test/A/Z.hs", testFile "MyProject.Test.A.Z" "AZ")
, ("MyProject/Test/B.hs", testFile "MyProject.Test.B" "B")
, ("MyProject/Test/C/A.hs", testFile "MyProject.Test.C.A" "CA")
, ("MyProject/Test/C/B.hs", testFile "MyProject.Test.C.B" "CB")
]
testFile moduleName ident =
[ "{- AUTOCOLLECT.TEST -}"
, "module " <> moduleName <> " where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test #1 for " <> ident <> "\" $ pure ()"
, "test = testCase \"test #2 for " <> ident <> "\" $ pure ()"
]
test = testCase "generateMain orders test modules alphabetically" $ do
(stdout, _) <-
assertSuccess . runMainWith (setTestFiles testFiles) $
[ "{- AUTOCOLLECT.MAIN"
, "group_type = modules"
, "-}"
]
getTestLines stdout
@?~ startsWith
[ "Main.hs"
, " A"
, " test: OK"
, " A.A"
, " test: OK"
, " A.B"
, " test: OK"
, " B"
, " test: OK"
, " C"
, " test: OK"
]
where
testFiles =
[ ("A.hs", testFile "A")
, ("A/A.hs", testFile "A.A")
, ("A/B.hs", testFile "A.B")
, ("B.hs", testFile "B")
, ("C.hs", testFile "C")
]
testFile moduleName =
[ "{- AUTOCOLLECT.TEST -}"
, "module " <> moduleName <> " where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test\" $ pure ()"
]
test = testCase "allows stripping suffix from test modules" $ do
(stdout, _) <-
assertSuccess . runMainWith (setTestFiles testFiles) $
[ "{- AUTOCOLLECT.MAIN"
, "group_type = modules"
, "strip_suffix = Foo"
, "-}"
]
getTestLines stdout
@?~ startsWith
[ "Main.hs"
, " Tests.A"
, " test: OK"
, " Tests.B"
, " test: OK"
]
where
testFiles =
[ ("Tests/AFoo.hs", testFile "Tests.AFoo")
, ("Tests/BFoo.hs", testFile "Tests.BFoo")
]
testFile moduleName =
[ "{- AUTOCOLLECT.TEST -}"
, "module " <> moduleName <> " where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test\" $ pure ()"
]
test = testCase "suffix is stripped before building module tree" $ do
(stdout, _) <-
assertSuccess . runMainWith (setTestFiles testFiles) $
[ "{- AUTOCOLLECT.MAIN"
, "group_type = tree"
, "strip_suffix = Test"
, "-}"
]
getTestLines stdout
@?~ startsWith
[ "Main.hs"
, " A"
, " B"
, " C"
, " test1: OK" -- should be under the same "C" as the "C.DTest" test module
, " D"
, " test2: OK"
]
where
testFiles =
[
( "A/B/CTest.hs"
,
[ "{- AUTOCOLLECT.TEST -}"
, "module A.B.CTest where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test1\" $ pure ()"
]
)
,
( "A/B/C/DTest.hs"
,
[ "{- AUTOCOLLECT.TEST -}"
, "module A.B.C.DTest where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test2\" $ pure ()"
]
)
]
test = testCase "allows adding extra ingredients" $ do
(stdout, _) <-
assertSuccess . runMainWith (addFiles [("MyIngredient.hs", ingredientFile)]) $
[ "{- AUTOCOLLECT.MAIN"
, "ingredients = MyIngredient.sayHelloAndExit"
, "-}"
]
stdout @?= "Hello!\n"
where
ingredientFile =
[ "module MyIngredient where"
, "import Test.Tasty.Ingredients"
, "sayHelloAndExit :: Ingredient"
, "sayHelloAndExit = TestManager [] $ \\_ _ -> Just $"
, " putStrLn \"Hello!\" >> pure True"
]
test = testCase "gives informative error when ingredient lacks module" $ do
(_, stderr) <-
assertAnyFailure . runMain $
[ "{- AUTOCOLLECT.MAIN"
, "ingredients = myIngredient"
, "-}"
]
getTestLines stderr @?~ containsStripped (eq "Ingredient needs to be fully qualified: myIngredient")
test = testCase "allows disabling default tasty ingredients" $ do
(_, stderr) <-
assertAnyFailure . runMain $
[ "{- AUTOCOLLECT.MAIN"
, "ingredients_override = true"
, "-}"
]
stderr @?~ startsWith "No ingredients agreed to run."
test = testCase "allows overriding suite name" $ do
(stdout, _) <-
assertSuccess . runMain $
[ "{- AUTOCOLLECT.MAIN"
, "suite_name = my-test-suite"
, "-}"
]
stdout @?~ startsWith "my-test-suite"
test = testCase "allows importing configuration" $ do
(stdout, _) <-
assertSuccess . runMainWith (addFiles [("autocollect.conf", config), testFile]) $
[ "{- AUTOCOLLECT.MAIN"
, "import = autocollect.conf"
, "suite_name = my-actual-test-suite"
, "-}"
]
stdout @?~ startsWith "my-actual-test-suite"
getTestLines stdout @?~ containsStripped (eq "MyLibrary")
where
config =
[ "# this is a comment in imported config"
, "suite_name = my-test-suite"
, "strip_suffix = Test"
]
testFile =
( "MyLibraryTest.hs"
,
[ "{- AUTOCOLLECT.TEST -}"
, "module MyLibraryTest where"
, "import Test.Tasty.HUnit"
, "test = testCase \"my test\" $ pure ()"
]
)
test = testCase "allows customizing main module" $ do
(stdout, _) <-
assertSuccess . runMainWith (setTestFiles testFiles) $
[ "{- AUTOCOLLECT.MAIN"
, "custom_main = true"
, "group_type = modules"
, "strip_suffix = Test"
, "-}"
, ""
, "{- AUTOCOLLECT.MAIN.imports -}"
, "import Test.Tasty"
, ""
, "main :: IO ()"
, "main = do"
, " putStrLn \"hello world!\""
, " defaultMain $ testGroup \"my tests\" tests"
, " where"
, " tests = id {- AUTOCOLLECT.MAIN.tests -}"
]
getTestLines stdout
@?~ startsWith
[ "hello world!"
, "my tests"
, " A"
, " test: OK"
, " A.A"
, " test: OK"
, " B"
, " test: OK"
]
where
testFiles =
[ ("A.hs", testFile "A")
, ("A/ATest.hs", testFile "A.ATest")
, ("BTest.hs", testFile "BTest")
]
testFile moduleName =
[ "{- AUTOCOLLECT.TEST -}"
, "module " <> moduleName <> " where"
, "import Test.Tasty.HUnit"
, "test = testCase \"test\" $ pure ()"
]
{----- Helpers -----}
setTestFiles :: [(FilePath, FileContents)] -> GHCProject -> GHCProject
setTestFiles testFiles proj =
proj
{ files = filter ((== "Main.hs") . fst) (files proj) ++ testFiles
}
runMain :: FileContents -> IO (ExitCode, Text, Text)
runMain = runMainWith id
runMainWith :: (GHCProject -> GHCProject) -> FileContents -> IO (ExitCode, Text, Text)
runMainWith f mainFile =
runghc . f $
GHCProject
{ dependencies = ["tasty", "tasty-hunit"]
, extraGhcArgs = ["-F", "-pgmF=tasty-autocollect"]
, files =
[ ("Main.hs", mainFile)
, testFile "FooTest"
, testFile "BarTest"
]
, preRunCallback = \_ -> pure ()
, entrypoint = "Main.hs"
, runArgs = []
}
where
testFile moduleName =
( Text.unpack moduleName <> ".hs"
,
[ "{- AUTOCOLLECT.TEST -}"
, "module " <> moduleName <> " ({- AUTOCOLLECT.TEST.export -}) where"
, "import Test.Tasty"
, "import Test.Tasty.HUnit"
, ""
, "test = testCase \"a test in " <> moduleName <> "\" $ pure ()"
]
)