cabal-testsuite/src/Test/Cabal/TestCode.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE DerivingStrategies #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5
   6 -- | Exception type like 'ExitCode' but with more information
   7 -- than just integer.
   8 module Test.Cabal.TestCode (
   9     -- * TestCode
  10     TestCode (..),
  11     FlakyStatus (..),
  12     IssueID (..),
  13     displayTestCode,
  14     isTestCodeSkip,
  15     isTestCodeFlaky,
  16     isTestCodeUnexpectedSuccess,
  17 ) where
  18
  19 import Control.Exception (Exception (..))
  20 import Data.Typeable     (Typeable)
  21
  22 -------------------------------------------------------------------------------
  23 -- TestCode
  24 -------------------------------------------------------------------------------
  25
  26 data TestCode
  27     = TestCodeOk
  28     | TestCodeSkip String
  29     | TestCodeKnownFail IssueID
  30     | TestCodeUnexpectedOk IssueID
  31     | TestCodeFail
  32     | TestCodeFlakyFailed IssueID
  33     | TestCodeFlakyPassed IssueID
  34   deriving (Eq, Show, Read, Typeable)
  35
  36 instance Exception TestCode
  37   where
  38     displayException = displayTestCode
  39
  40 displayTestCode :: TestCode -> String
  41 displayTestCode TestCodeOk               = "OK"
  42 displayTestCode (TestCodeSkip msg)       = "SKIP " ++ msg
  43 displayTestCode (TestCodeKnownFail t)    = "OK (known failure, see #" <> show t <> ")"
  44 displayTestCode (TestCodeUnexpectedOk t) = "FAIL (unexpected success, see #" <> show t <> ")"
  45 displayTestCode TestCodeFail             = "FAIL"
  46 displayTestCode (TestCodeFlakyFailed t)  = "FLAKY (FAIL, see #" <> show t <> ")"
  47 displayTestCode (TestCodeFlakyPassed t)  = "FLAKY (OK, see #" <> show t <> ")"
  48
  49 isTestCodeSkip :: TestCode -> Bool
  50 isTestCodeSkip (TestCodeSkip _) = True
  51 isTestCodeSkip _                = False
  52
  53 type TestPassed = Bool
  54
  55 newtype IssueID = IssueID Int
  56   deriving newtype (Eq, Typeable, Num, Show, Read)
  57
  58 data FlakyStatus
  59   = NotFlaky
  60   | Flaky TestPassed IssueID
  61
  62 isTestCodeFlaky :: TestCode -> FlakyStatus
  63 isTestCodeFlaky (TestCodeFlakyPassed t) = Flaky True t
  64 isTestCodeFlaky (TestCodeFlakyFailed t) = Flaky False t
  65 isTestCodeFlaky _                       = NotFlaky
  66
  67 isTestCodeUnexpectedSuccess :: TestCode -> Maybe IssueID
  68 isTestCodeUnexpectedSuccess (TestCodeUnexpectedOk t) = Just t
  69 isTestCodeUnexpectedSuccess _                        = Nothing