Skip to content

Instantly share code, notes, and snippets.

@nmattia nmattia/tasty-names.hs
Last active Apr 29, 2018

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
You can’t perform that action at this time.
You signed in with another tab or window. Reload to refresh your session. You signed out in another tab or window. Reload to refresh your session.