Update to formatters V2 and add durations (#6)

Co-authored-by: kazk <[email protected]>

Author: hobovsky

hspec-formatters-codewars.cabal

@@ -45,7 +45,8 @@ test-suite hspec-formatters-codewars-test
       test
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      QuickCheck
+    , base >=4.7 && <5
     , hspec >=2.8
     , hspec-core >=2.8
     , hspec-formatters-codewars

package.yaml

@@ -48,6 +48,7 @@ tests:
     - hspec >= 2.8
     - hspec-core >= 2.8
     - hspec-formatters-codewars
+    - QuickCheck
     verbatim:
       build-tool-depends:
         hspec-discover:hspec-discover

src/Test/Hspec/Formatters/Codewars.hs

@@ -1,50 +1,81 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Test.Hspec.Formatters.Codewars (codewars) where
+module Test.Hspec.Formatters.Codewars (codewars, escapeLF) where
 
 import Data.Text (pack, replace, unpack)
+import Text.Printf (printf)
+import Data.IORef
+import Control.Monad.IO.Class
+import Test.Hspec.Core.Util (Path)
 
-import Test.Hspec.Core.Formatters.V1 (
+import Test.Hspec.Core.Formatters.V2 (
   FailureReason (..),
-  Formatter (..),
+  Formatter     (..),
+  Item          (..),
+  Seconds       (..),
+  Result        (..),
   formatException,
   silent,
   writeLine,
+  getRealTime
  )
 
-codewars :: Formatter
-codewars =
-  silent
-    { exampleGroupStarted = \_ name -> do
+getName :: Path -> String
+getName (_, req) = escapeLF req
+
+codewars :: IO Formatter
+codewars = do
+  times <- newIORef ([ ]::[Seconds])
+  pure $ silent
+    {
+      formatterGroupStarted = \path -> do
+        writeLine ""
+        startedOn <- getRealTime
+        liftIO $ modifyIORef times (startedOn : )
+        writeLine $ "<DESCRIBE::>" ++ (getName path)
+      ,formatterGroupDone = \_ -> do
         writeLine ""
-        writeLine $ escapeLF $ "<DESCRIBE::>" ++ name
-    , exampleGroupDone = writeLine "\n<COMPLETEDIN::>"
-    , exampleSucceeded = \(_, name) _ -> do
+        ts <- liftIO $ readIORef times
+        now <- getRealTime
+        let startedOn = head ts
+        let duration = now - startedOn
+        writeLine $ "<COMPLETEDIN::>" ++ (formatToMillis $ duration)
+        liftIO $ modifyIORef times tail
+      ,formatterItemStarted = \path -> do
         writeLine ""
-        writeLine $ escapeLF $ "<IT::>" ++ name
-        writeLine "\n<PASSED::>Test Passed"
-        writeLine "\n<COMPLETEDIN::>"
-    , exampleFailed = \(_, name) _ reason -> do
+        writeLine $ "<IT::>" ++ (getName path)
+      ,formatterItemDone = \_ item -> do
         writeLine ""
-        writeLine $ escapeLF $ "<IT::>" ++ name
+        writeLine $ reportItem item
         writeLine ""
-        writeLine $ escapeLF $ reasonAsString reason
-        writeLine "\n<COMPLETEDIN::>"
+        writeLine $ "<COMPLETEDIN::>" ++ (formatToMillis $ itemDuration item)
     }
 
+reportItem :: Item -> String
+reportItem item =
+  case itemResult item of
+    Success -> "<PASSED::>Test Passed"
+    Failure _ reason -> reasonAsString reason
+    Pending _  Nothing -> "<FAILED::>Test pending: no reason given"
+    Pending _  (Just msg) -> "<FAILED::>Test pending: " ++ (escapeLF msg)
+
 reasonAsString :: FailureReason -> String
 reasonAsString reason =
   case reason of
     NoReason -> "<FAILED::>Test Failed"
-    Reason x -> "<FAILED::>" ++ x
+    Reason x -> "<FAILED::>" ++ (escapeLF x)
     ExpectedButGot Nothing expected got ->
-      "<FAILED::>Expected " ++ expected ++ " but got " ++ got
+      "<FAILED::>expected: " ++ (escapeLF expected) ++ "<:LF:> but got: " ++ (escapeLF got)
     ExpectedButGot (Just src) expected got ->
-      "<FAILED::>" ++ src ++ " expected " ++ expected ++ " but got " ++ got
+      "<FAILED::>" ++ (escapeLF src) ++ "<:LF:>expected: " ++ (escapeLF expected) ++ "<:LF:> but got: " ++ (escapeLF got)
     Error Nothing err ->
-      "<ERROR::>" ++ formatException err
+      "<ERROR::>uncaught exception: " ++ (escapeLF $ formatException err)
     Error (Just s) err ->
-      "<ERROR::>" ++ s ++ formatException err
+      "<ERROR::>" ++ (escapeLF s) ++ "<:LF:>" ++ (escapeLF $ formatException err)
+
+
+formatToMillis :: Seconds -> String
+formatToMillis (Seconds s) = printf "%.3f" (s * 1000)
 
 escapeLF :: String -> String
 escapeLF = unpack . replace "\n" "<:LF:>" . pack

test/ExampleSpec.hs

@@ -1,11 +1,45 @@
 module ExampleSpec where
 
 import Test.Hspec
+import Test.QuickCheck
 
 spec :: Spec
 spec = describe "ExampleSpec" $ do
-  it "can parse integers" $ do
-    read "10" `shouldBe` (10 :: Int)
-
-  it "can parse floating-point numbers" $ do
-    read "2.5" `shouldBe` (2.5 :: Float)
+  describe "Passing tests" $ do
+    it "can parse integers" $ do
+      read "10" `shouldBe` (10 :: Int)
+    it "can parse floating-point numbers" $ do
+      read "2.5" `shouldBe` (2.5 :: Float)
+  describe "Failing tests" $ do
+    it "can parse integers and fail" $ do
+      read "10" `shouldBe` (11 :: Int)
+    it "can parse floating-point numbers and fail" $ do
+      read "2.5" `shouldBe` (2.6 :: Float)
+    it "explicitly trigerred error" $ do
+      error "This test fails with an error"
+      read "10" `shouldBe` (10 :: Int)
+  describe "Crashing tests" $ do
+    it "can parse integers and crash" $ do
+      read (last $ tail $ [ "10" ]) `shouldBe` (11 :: Int)
+    it "can parse floating-point numbers and crash" $ do
+      read (last $ tail $ [ "2.5" ]) `shouldBe` (2.6 :: Float)
+  describe "Pending tests" $ do
+    it "not implemented" $ do
+      pending
+    it "not implemented, with a message" $ do
+      pendingWith "Not implemented yet"
+  describe "Can present\nmultiline titles\nof groups" $ do
+    it "Can present\nmultiline titles\nof items" $ do
+      read "10" `shouldBe` (10 :: Int)
+    it "Can present multiline assertions" $ do
+      (show 10) `shouldBe`  "10, but\nbroken into\nmultiple lines"
+  describe "QuickCheck tests" $ do
+    it "passes for random ints" $ do
+      property $ \ n -> do
+        ((read (show n))::Int) `shouldBe` (n :: Int)
+    it "fails for random ints" $ do
+      property $ \ n -> do
+        ((read (show n))::Int) `shouldBe` ((if n < 50 then n else n + 1) :: Int)
+--  describe "Can crash whole test suite" $ do
+--    it ("can parse item title " ++ (show $ ((read "cant parse this")::Int)) ++ " and crash") $ do
+--      read "2.5" `shouldBe` (2.5 :: Float)

test/Main.hs

@@ -1,10 +1,20 @@
 module Main (main) where
 
+import System.Exit
+
 import Test.Hspec.Runner
-import Test.Hspec.Formatters.Codewars (codewars)
-import Test.Hspec.Core.Formatters.V1 (formatterToFormat)
+import Test.Hspec.Formatters.Codewars (codewars, escapeLF)
+import Test.Hspec.Core.Formatters.V2 (formatterToFormat, formatException)
+import Test.Hspec.Core.Util (safeTry)
 
 import qualified Spec
 
 main :: IO ()
-main = hspecWith defaultConfig {configFormat = Just $ formatterToFormat codewars} Spec.spec
+main = do
+  formatter <- codewars
+  summary <- safeTry $ runSpec Spec.spec defaultConfig {configFormat = Just $ formatterToFormat formatter}
+  case summary of
+    Left ex -> do
+      putStrLn $ "\n<ERROR::>Test suite crashed<:LF:>" ++ (escapeLF $ formatException ex)
+      exitFailure
+    Right s -> evaluateSummary s