Access the test name in tasty

tasty-names.hs

{-# 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
    ]