diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Michael Xavier + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# tasty-tap - TAP (Test Anything Protocol) formatter for tasty diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,2 @@ +0.0.1 +* Initial release diff --git a/src/Test/Tasty/Runners/TAP.hs b/src/Test/Tasty/Runners/TAP.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Runners/TAP.hs @@ -0,0 +1,84 @@ +-- | This is a TAP13 (Test Anything Protocol version 13) compatible +-- test output formatter for tasty. You can read more about tap +-- . +module Test.Tasty.Runners.TAP + ( tapRunner + , tapRunner' + ) where + + +------------------------------------------------------------------------------- +import Control.Concurrent.STM +import Control.Monad +import qualified Data.IntMap.Strict as IM +import Data.List +import Data.Maybe +import Data.Monoid +import System.IO +import Test.Tasty.Ingredients +import Test.Tasty.Options +import Test.Tasty.Runners +------------------------------------------------------------------------------- + + +tapRunner :: Ingredient +tapRunner = tapRunner' stdout + +------------------------------------------------------------------------------- +tapRunner' :: Handle -> Ingredient +tapRunner' h = TestReporter reporterOpts go + where reporterOpts = [] + go opts tree = (Just (tapCallback h opts tree)) + + +------------------------------------------------------------------------------- +tapCallback + :: Handle + -> OptionSet + -> TestTree + -> StatusMap + -> IO (Time -> IO Bool) +tapCallback h opts tree smap = do + let names = IM.fromList (zip [0..] (testsNames opts tree)) + hPutStrLn h tapHeader + hPutStrLn h (tapPlan smap) + results <- forM (IM.toList smap) $ \(idx, stat) -> do + let n = fromMaybe mempty (IM.lookup idx names) + reportStatus h n idx stat + return (const (return (and results))) + + +------------------------------------------------------------------------------- +tapHeader :: String +tapHeader = "TAP version 13" + + +------------------------------------------------------------------------------- +tapPlan :: StatusMap -> String +tapPlan sm | IM.null sm = "Bail out! There were no tests to run." + | otherwise = "1.." <> show (IM.size sm) + + +------------------------------------------------------------------------------- +reportStatus :: Handle -> String -> Int -> TVar Status -> IO Bool +reportStatus h name zeroIdx statRef = do + res <- atomically (waitFinished ) + hPutStrLn h (renderResult res) + return (resultSuccessful res) + where testNum = zeroIdx + 1 + waitFinished = do stat <- readTVar statRef + case stat of + Done res -> return res + _ -> retry + renderResult res + | resultSuccessful res = "ok " <> show testNum <> " - " <> name <> desc + | otherwise = "not ok " <> show testNum <> " - " <> name <> desc + --TODO: how do we get the test name? + where desc = case resultDescription res of + "" -> "" + nonEmpty -> "\n" <> formatDesc nonEmpty + + +------------------------------------------------------------------------------- +formatDesc :: String -> String +formatDesc = intercalate "\n" . map ("# " <> ) . lines diff --git a/tasty-tap.cabal b/tasty-tap.cabal new file mode 100644 --- /dev/null +++ b/tasty-tap.cabal @@ -0,0 +1,58 @@ +name: tasty-tap +version: 0.0.1 +synopsis: TAP (Test Anything Protocol) Version 13 formatter for tasty +description: A tasty ingredient to output test results in TAP 13 format. +license: MIT +license-file: LICENSE +author: Michael Xavier +maintainer: michael@michaelxavier.net +homepage: https://github.com/michaelxavier/tasty-tap +copyright: (C) 2015 Michael Xavier +category: Testing +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 +extra-source-files: + README.md + changelog.md + +source-repository head + type: git + location: git://github.com/michaelxavier/tasty-tap.git + +flag lib-Werror + default: False + manual: True + +library + exposed-modules: Test.Tasty.Runners.TAP + build-depends: base >=4.6 && <4.9 + , tasty >= 0.10 && < 0.11 + , stm + , containers + hs-source-dirs: src + default-language: Haskell2010 + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall + + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + + build-depends: base + , tasty + , tasty-tap + , tasty-hunit + , tasty-golden + , directory + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,65 @@ +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Control.Exception +import System.Directory +import System.Exit +import System.IO +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit +------------------------------------------------------------------------------- +import Test.Tasty.Runners.TAP +------------------------------------------------------------------------------- + + + +--TODO: actually make assertions +main :: IO () +main = do + tmpDir <- getTemporaryDirectory + defaultMain (tests tmpDir) + -- defaultMainWithIngredients [tapRunner] exampleTests + + +------------------------------------------------------------------------------- +tests :: FilePath -> TestTree +tests tmpDir = testGroup "Test.Tasty.Runners.TAP" + [ + let tmpPath = tmpDir ++ "/simple.tap" + in goldenVsFileDiff "simple.tap" + diffCmd + (goldenPath "simple.tap") + tmpPath + (mkSimple tmpPath) + ] + + +------------------------------------------------------------------------------- +diffCmd :: FilePath -> FilePath -> [String] +diffCmd ref new = ["diff", "-u", ref, new] + + +------------------------------------------------------------------------------- +mkSimple :: FilePath -> IO () +mkSimple tmpPath = bracket (openFile tmpPath WriteMode) hClose $ \h -> do + defaultMainWithIngredients [tapRunner' h] exampleTests `catch` interceptExit + where interceptExit :: ExitCode -> IO () + interceptExit _ = return () + + +------------------------------------------------------------------------------- +exampleTests :: TestTree +exampleTests = testGroup "some example tests" + [ + testCase "passes" $ assertBool "uh your computer is busted" True + , testCase "fails" $ assertFailure "this was doomed" + ] + + +------------------------------------------------------------------------------- +goldenPath :: FilePath -> FilePath +goldenPath fp = "test/golden/" ++ fp