HTF 0.11.3.4 → 0.11.4.0

raw patch · 8 files changed

+100/−25 lines, 8 filesdep +base64-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base64-bytestring

API changes (from Hackage documentation)

Files

• HTF.cabal +3/−2
• Test/Framework/Colors.hs +8/−1
• Test/Framework/Diff.hs +0/−6
• Test/Framework/HUnitWrapper.hs +14/−6
• Test/Framework/QuickCheckWrapper.hs +29/−3
• Test/Framework/TestManager.hs +9/−2
• Test/Framework/TestManagerInternal.hs +35/−4
• tests/test-HTF.cabal +2/−1

@@ -1,5 +1,5 @@ Name:             HTF-Version:          0.11.3.4+Version:          0.11.4.0 License:          LGPL License-File:     LICENSE Copyright:        (c) 2005-2012 Stefan Wehr@@ -169,7 +169,8 @@                     text >= 0.11,                     old-time >= 1.0,                     array,-                    xmlgen >= 0.6+                    xmlgen >= 0.6,+                    base64-bytestring   if !os(windows)     Build-Depends:   unix >= 2.4   Exposed-Modules:

@@ -26,12 +26,13 @@   , emptyColorString, (+++), unlinesColorString, colorStringFind, ensureNewlineColorString   , colorize, colorizeText, colorize', colorizeText'   , noColor, noColorText, noColor', noColorText'-  , renderColorString+  , renderColorString, maxLength  ) where  import qualified Data.Text as T import Data.String+import Data.Maybe import Control.Monad  firstDiffColor = Color Magenta False@@ -88,6 +89,12 @@  emptyColorString :: ColorString emptyColorString = noColor ""++maxLength :: ColorString -> Int+maxLength (ColorString prims) =+    let ml (PrimColorString _ t mt) =+            max (T.length t) (fromMaybe 0 (fmap T.length mt))+    in sum $ map ml prims  unlinesColorString :: [ColorString] -> ColorString unlinesColorString l =

@@ -95,15 +95,9 @@                       string)                  emptyColorString (addPositions groups)     where-#if MIN_VERSION_Diff(0,2,0)       showDiffGroup _ (D.First s) = dc_fromFirst dc s       showDiffGroup _ (D.Second s) = dc_fromSecond dc s       showDiffGroup pos (D.Both inBoth _) =-#else-      showDiffGroup _ (D.F, s) = dc_fromFirst dc s-      showDiffGroup _ (D.S, s) = dc_fromSecond dc s-      showDiffGroup pos (D.B, inBoth) =-#endif           let showStart = not $ isFirst pos               showEnd = not $ isLast pos               (contextStart, ignored, contextEnd) =

@@ -103,8 +103,11 @@    -- * Sub assertions   subAssert_, subAssertVerbose_,-  gsubAssert_, gsubAssertVerbose_+  gsubAssert_, gsubAssertVerbose_, +  -- * HUnit re-exports+  HU.HUnitFailure+ ) where  import Control.Exception@@ -113,6 +116,7 @@ import Control.Monad.Trans import qualified Language.Haskell.Exts.Pretty as HE import qualified Language.Haskell.Exts.Parser as HE+import qualified Test.HUnit.Lang as HU  import Data.List ( (\\) ) import System.IO.Unsafe (unsafePerformIO)@@ -359,10 +363,14 @@         na = length actual         in case () of             _| ne /= na ->-                 genericAssertFailure__ loc (mkMsg name s-                                             ("failed at " ++ showLoc loc-                                              ++ "\n expected length: " ++ show ne-                                              ++ "\n actual length: " ++ show na))+                 do let x = equalityFailedMessage (show expected) (show actual)+                    genericAssertFailure__ loc (mkColorMsg name s+                                                (noColor+                                                 ("failed at " ++ showLoc loc+                                                  ++ "\n expected length: " ++ show ne+                                                  ++ "\n actual length: " ++ show na) ++++                                                  (if maxLength x < 5000+                                                   then x else emptyColorString)))              | not (unorderedEq expected actual) ->                  do let x = equalityFailedMessage (show expected) (show actual)                     genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s@@ -458,7 +466,7 @@     _assertThrows_ name loc s x (\ (_e::SomeException) -> True) DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not                        throw an exception.)-CreateAssertionsNoGVariant(assertThrowsSome, IO a)+CreateAssertionsNoGVariant(assertThrowsSome, a)  -- -- Assertions on Either

@@ -37,6 +37,12 @@   -- * Pending properties   qcPending, +  -- * Auxiliary functions+#if !MIN_VERSION_QuickCheck(2,7,0)+  ioProperty,+#endif+  assertionAsProperty,+   -- * Internal functions   qcAssertion @@ -46,17 +52,22 @@ import Prelude hiding ( catch ) #endif import Control.Exception ( SomeException, Exception, Handler(..),-                           throw, catch, catches, evaluate )+                           throw, throwIO, catch, catches, evaluate ) import Data.Typeable (Typeable) import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Base64 as Base64  import Test.QuickCheck-+import Test.QuickCheck.Property hiding (reason) import Test.Framework.TestManager import Test.Framework.TestManagerInternal+import Test.HUnit.Lang (HUnitFailure(..))  data QCState = QCState { qc_args :: !Args } @@ -123,7 +134,8 @@                                                in take (length s - length pendingSuffix) s                               in quickCheckTestPending pendingMsg                          else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))-                                 quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))+                                     out = adjustOutput msg+                                 quickCheckTestFail (Just (out ++ "\n" ++ replay))                   Right (GaveUp { output=msg }) ->                       quickCheckTestFail (Just (adjustOutput msg))                   Right (NoExpectedFailure { output=msg }) ->@@ -172,3 +184,17 @@ -- without removing it from the test suite and without deleting or commenting out the property code. qcPending :: Testable t => String -> t -> t qcPending msg _ = throw (QCPendingException msg)++#if !MIN_VERSION_QuickCheck(2,7,0)+ioProperty :: Testable prop => IO prop -> Property+ioProperty = morallyDubiousIOProperty+#endif++assertionAsProperty :: IO () -> Property+assertionAsProperty action =+    ioProperty $ catch action transHUnitFail >> return True+    where+      transHUnitFail exc@(HUnitFailure msg) =+          let exc' = "<<<HTF<<<" ++ (BSC.unpack $ Base64.encode $ T.encodeUtf8 $ T.pack msg)+                     ++ ">>>HTF>>>"+          in throwIO (HUnitFailure exc')

@@ -46,6 +46,7 @@ import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs) import Control.Exception (finally)+import Data.Maybe import qualified Data.List as List  import System.IO@@ -148,8 +149,14 @@                                               | isFailure -> Fail                                               | otherwise -> Error                                    in (r, (utr_location utr, utr_callingLocations utr, utr_message utr, time))-                              else let (r, s) = deserializeQuickCheckMsg msg'-                                   in (r, (Nothing, [], noColor s, time))+                              else let (r, mUnitTestResult, s) = deserializeQuickCheckMsg msg'+                                       loc = join $ fmap utr_location mUnitTestResult+                                       callers = fromMaybe [] $ fmap utr_callingLocations mUnitTestResult+                                       msg =+                                           case mUnitTestResult of+                                             Just utr -> utr_message utr +++ noColor "\n" +++ noColor s+                                             Nothing -> noColor s+                                   in (r, (loc, callers, msg, time))               rr = FlatTest                      { ft_sort = ft_sort ft                      , ft_path = ft_path ft

@@ -36,6 +36,10 @@ import qualified Test.HUnit.Lang as HU import Control.Monad.Trans.Control import qualified Control.Exception.Lifted as Exc+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as BSC  assertFailureHTF :: String -> Assertion -- Important: force the string argument, otherwise an error embedded@@ -56,15 +60,42 @@ quickCheckTestPass :: String -> Assertion quickCheckTestPass m = assertFailureHTF (show (Pass, Just m)) -deserializeQuickCheckMsg :: String -> (TestResult, String)+deserializeQuickCheckMsg :: String -> (TestResult, Maybe UnitTestResult, String) deserializeQuickCheckMsg msg =     case readM msg of       Nothing ->-          (Error, msg)+          (Error, Nothing, msg)       Just (r, ms) ->           case ms of-            Nothing -> (r, "")-            Just s -> (r, s)+            Nothing -> (r, Nothing, "")+            Just s ->+                let (utr, msg) = extractUnitTestResult (T.pack s)+                in (r, utr, T.unpack msg)+    where+      extractUnitTestResult t =+          case breakOn (T.pack "<<<HTF<<<") t of+            Nothing -> (Nothing, t)+            Just (pref, rest) ->+                case breakOn (T.pack ">>>HTF>>>") rest of+                  Nothing -> (Nothing, t)+                  Just (serUtr, suf) ->+                      case Base64.decode (BSC.pack (T.unpack serUtr)) of+                        Left _ -> (Nothing, t)+                        Right bs ->+                            case T.decodeUtf8' bs of+                              Left _ -> (Nothing, t)+                              Right x ->+                                  case readM (T.unpack x) of+                                    Nothing -> (Nothing, t)+                                    Just utr ->+                                        (Just utr,+                                         pref `T.append` suf)+      breakOn x t =+          case T.breakOn x t of+            (pref, suf) ->+                if T.null suf+                then Nothing+                else Just (pref, T.drop (T.length x) suf)  -- This is a HACK: we encode location and pending information as a datatype -- that we show and parse later using read.

@@ -28,7 +28,8 @@                      HUnit,                      QuickCheck,                      Diff,-                     haskell-src-exts+                     haskell-src-exts,+                     base64-bytestring   Default-language:  Haskell2010   Ghc-options: -threaded   Hs-source-dirs: ., ..