Create a gist now

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Access the test name in tasty
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC "-Wall" #-}
import Data.Semigroup
import Data.Char (toLower, isAlphaNum)
import Data.List (group)
import Data.Tagged (Tagged(..))
import Test.Tasty hiding (testGroup)
import Test.Tasty.HUnit ((@=?), Assertion, testCase)
import Test.Tasty.Options (IsOption (..))
import System.FilePath ((</>))
import System.Directory (createDirectoryIfMissing)
import qualified Test.Tasty
-- | The test names of the test tree
newtype TastyNames = TastyNames [String]
instance IsOption TastyNames where
defaultValue = TastyNames [] -- The base name
-- We don't care about the rest
parseValue _ = Nothing
optionName = Tagged ""
optionHelp = Tagged ""
-- | Create a named group of test cases or other groups while keeping track of
-- the specified 'TestName'
testGroup :: TestName -> [TestTree] -> TestTree
testGroup tn = adjustNames tn . Test.Tasty.testGroup tn
-- | Records the 'TestName' in the 'TastyNames' option.
adjustNames :: TestName -> TestTree -> TestTree
adjustNames tn = adjustOption f
where
f :: TastyNames -> TastyNames
f (TastyNames ns) = TastyNames (ns <> [tn])
-- | Turn an Assertion into a tasty test case, providing the 'TastyNames'
-- accumulated in the test tree.
testCaseWithNames :: TestName -> (TastyNames -> Assertion) -> TestTree
testCaseWithNames tn act = adjustNames tn $ askOption $ \tns ->
testCase tn $ act tns
-- | Turn an Assertion into a tasty test case, providing the a directory
-- created based on the accumulated names in the test tree.
testCaseWithDir :: TestName -> (FilePath -> Assertion) -> TestTree
testCaseWithDir tn act = testCaseWithNames tn $ \(TastyNames tns) -> do
let dir = foldr (</>) "" $ toFriendlyFilepath <$> tns
createDirectoryIfMissing True dir
act dir
where
-- bangs a string into a filepath-friendly name
toFriendlyFilepath :: String -> FilePath
toFriendlyFilepath = stripBoundayDash . collapseDashes . unhexToDash
stripBoundayDash = reverse . stripDash . reverse . stripDash
stripDash = dropWhile (== '-')
unhexToDash = fmap $ toLower . (\c -> if isAlphaNum c then c else '-')
collapseDashes = concatMap (\case { '-':_ -> ['-']; xs -> xs}) . group
main :: IO ()
main = defaultMain $ testGroup "foo"
[ testCaseWithNames "bar" $ \(TastyNames tns) -> ["foo", "bar"] @=? tns
, testCaseWithDir "bar, 3 (baz)" $ \fp -> "foo/bar-3-baz" @=? fp
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment