HTF 0.13.2.5 → 0.14.0.0

raw patch · 21 files changed

+142/−51 lines, 21 filesdep ~basedep ~randombuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, random

API changes (from Hackage documentation)

Files

• .travis.yml +2/−2
• ChangeLog +5/−0
• HTF.cabal +8/−3
• HTFPP.hs +9/−6
• Setup.hs +6/−1
• Test/Framework/AssertM.hs +3/−0
• Test/Framework/CmdlineOptions.hs +8/−5
• Test/Framework/Diff.hs +48/−4
• Test/Framework/HUnitWrapper.hs +10/−2
• Test/Framework/Preprocessor.hs +10/−4
• Test/Framework/TestManager.hs +2/−0
• Test/Framework/ThreadPool.hs +2/−2
• Test/Framework/Utils.hs +5/−0
• scripts/check.sh +7/−1
• scripts/local-htfpp +1/−10
• stack-ghc-7.10.yaml +0/−5
• stack-ghc-8.6.yaml +1/−1
• stack-ghc-8.8.yaml +7/−0
• stack.yaml +1/−1
• tests/TestHTF.hs +0/−2
• tests/compile-errors/run-tests.sh +7/−2

@@ -13,11 +13,11 @@ # The different configurations we want to test. You could also do things like # change flags or use --stack-yaml to point to a different file. env:+- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.8.yaml" - HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.6.yaml" - HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.4.yaml" - HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.2.yaml" - HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-8.0.yaml"-- HTF_TRAVIS_STACK_ARGS="--stack-yaml ${TRAVIS_BUILD_DIR}/stack-ghc-7.10.yaml"  before_install: # Download and unpack the stack executable@@ -28,7 +28,7 @@ # This line does all of the work: installs GHC if necessary, build the library, # executables, and test suites, and runs the test suites. --no-terminal works # around some quirks in Travis's terminal implementation.-script: stack $HTF_TRAVIS_STACK_ARGS --no-terminal --install-ghc test --haddock --cabal-verbose+script: ${TRAVIS_BUILD_DIR}/scripts/travis-check  # Caching so the next build will be fast too. cache:

@@ -1,3 +1,8 @@+* 0.14.0.0 (2019-11-26)+  - support for GHC 8.8+  - fix for performance problem with long strings+    https://github.com/skogsbaer/HTF/issues/85+ * 0.13.2.5 (2018-11-06)   - fix build problem with quickcheck:         https://github.com/skogsbaer/HTF/issues/70

@@ -1,5 +1,5 @@ Name:             HTF-Version:          0.13.2.5+Version:          0.14.0.0 License:          LGPL-2.1 License-File:     LICENSE Copyright:        (c) 2005-2015 Stefan Wehr@@ -30,7 +30,7 @@     blog article (<http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html>)     demonstrating HTF's coloring, pretty-printing and diff functionality. -Build-Type:       Simple+Build-Type:       Custom Cabal-Version:    >= 1.10 Extra-Source-Files:   README.md@@ -38,11 +38,11 @@   ChangeLog   .travis.yml   stack.yaml-  stack-ghc-7.10.yaml   stack-ghc-8.0.yaml   stack-ghc-8.2.yaml   stack-ghc-8.4.yaml   stack-ghc-8.6.yaml+  stack-ghc-8.8.yaml   tests/bbt/should_fail/BBTArgs   tests/bbt/should_fail/*.err   tests/bbt/should_fail/*.out@@ -86,6 +86,11 @@ Source-Repository head   Type:           git   Location:       http://github.com/skogsbaer/HTF.git++Custom-Setup+  Setup-Depends:   base == 4.*,+                   process,+                   Cabal  Executable htfpp   Main-Is:          HTFPP.hs

@@ -35,7 +35,7 @@ usage =     hPutStrLn stderr       ("Preprocessor for the Haskell Test Framework\n\n" ++-       "Usage: " ++ progName ++ " [--hunit|--debug|--version] [FILE1 [FILE2 [FILE3]]]\n\n" +++       "Usage: " ++ progName ++ " [--hunit|--debug|--version|--literate-tex] [FILE1 [FILE2 [FILE3]]]\n\n" ++        "* If no argument is given, input is read from stdin and\n" ++        "  output is written to stdout.\n" ++        "* If only FILE1 is given, input is read from this file\n" ++@@ -47,7 +47,9 @@        "  FILE1 serves as the original input filename.\n\n" ++        "The `--hunit' flag causes assert-like macros to be expanded in a way\n" ++        "that is backwards-compatible with the corresponding functions of the\n" ++-       "HUnit library.")+       "HUnit library.\n" +++       "The `--literate-tex` flag causes the additional generated code to be wrapped\n" +++       "in TeX-style literate code blocks.")  outputVersion :: IO () outputVersion =@@ -73,9 +75,10 @@        when ("--version" `elem` args) $             do outputVersion                exitWith ExitSuccess-       let hunitBackwardsCompat = "--hunit" `elem` args-           debug = "--debug" `elem` args-           restArgs = flip filter args $ \x -> x /= "--hunit" && x /= "--debug"+       let transformOpts = TransformOptions { hunitBackwardsCompat = "--hunit" `elem` args+                                            , debug = "--debug" `elem` args+                                            , literateTex = "--literate-tex" `elem` args }+           restArgs = flip filter args $ \x -> not $ x `elem` ["--hunit", "--debug", "--literate-tex"]        (origInputFilename, hIn, hOut) <-            case restArgs of              [] ->@@ -96,7 +99,7 @@                     usage                     exitWith (ExitFailure 1)        input <- hGetContents hIn-       output <- transform hunitBackwardsCompat debug origInputFilename input `catch`+       output <- transform transformOpts origInputFilename input `catch`                    (\ (e::SomeException) ->                         do hPutStrLn stderr (progName ++                                              ": unexpected exception: " ++

@@ -1,5 +1,10 @@ #!/usr/bin/runhaskell  import Distribution.Simple+import System.Process -main = defaultMain+main = defaultMainWithHooks (simpleUserHooks { preConf = preTestHook })+    where+      preTestHook args flags =+          do system ("bash ./scripts/prepare")+             preConf simpleUserHooks args flags

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-|  This module defines the 'AssertM' monad, which allows you either to run assertions@@ -55,7 +56,9 @@     return = AssertOk     AssertFailed stack >>= _ = AssertFailed stack     AssertOk x >>= k = k x+#if !(MIN_VERSION_base(4,13,0))     fail msg = AssertFailed [AssertStackElem (Just msg) Nothing]+#endif  instance AssertM AssertBool where     genericAssertFailure__ loc s =

@@ -347,9 +347,12 @@           case opts_historyFile opts of             Just fp -> return fp             Nothing ->-                do x <- getProgName-                   createDirectoryIfMissing False ".HTF"-                   return (".HTF/" ++ x ++ ".history")+                do progName <- getProgName+                   let x = if progName == "<interactive>" then "interactive" else progName+                   curDir <- getCurrentDirectory+                   let dir = curDir </> ".HTF"+                   createDirectoryIfMissing False dir+                   return $ dir </> (x ++ ".history")       getHistory fp =           do b <- doesFileExist fp              if not b@@ -358,10 +361,10 @@                      case deserializeTestHistory bs of                        Right history -> return history                        Left err ->-                           do hPutStrLn stderr ("Error deserializing content of history file " ++ fp ++ ": " ++ err)+                           do hPutStrLn stderr ("Error deserializing content of HTF history file " ++ fp ++ ": " ++ err)                               return emptyTestHistory                   `catch` (\(e::IOException) ->-                               do hPutStrLn stderr ("Error reading history file " ++ fp ++ ": " ++ show e)+                               do hPutStrLn stderr ("Error reading HTF history file " ++ fp ++ ": " ++ show e)                                   return emptyTestHistory)       mergeFilters f1 f2 t =           f1 t && f2 t

@@ -88,12 +88,50 @@ contextSize :: Int contextSize = 10 +prepareStringsForDiff :: String -> String -> (String, String, Maybe (String, String))+prepareStringsForDiff s1 s2 =+    case (List.splitAt 1024 s1, List.splitAt 1024 s2) of+      ((start1, rest1@(_:_)), (start2, rest2@(_:_))) -> (start1, start2, Just (rest1, rest2))+      ((start1, []), (start2, _)) -> (start1, start2, Nothing)+      ((start1, _), (start2, [])) -> (start1, start2, Nothing)+ singleLineDiff :: DiffConfig -> String -> String -> ColorString-singleLineDiff dc s1 s2-    | s1 == s2 = emptyColorString+singleLineDiff dc s1 s2 = loop (0, 0) (s1, s2)+    where+      loop :: (Int, Int) -> (String, String) -> ColorString+      loop (skipped1, skipped2) (s1, s2) =+          let (start1, start2, cont) = prepareStringsForDiff s1 s2+          in case singleLineDiff' dc start1 start2 of+               Just cs ->+                   let prefix =+                           if skipped1 == 0 && skipped1 == 0+                           then emptyColorString+                           else dc_skip dc+                                    ("skipped " ++ show skipped1 +++                                     " chars from first string, "+                                    ++ show skipped2 ++ " chars from second string")+                       suffix =+                           case cont of+                             Nothing -> emptyColorString+                             Just (r1, r2) ->+                                 dc_skip dc+                                     ("skipped " ++ show (length r1) +++                                      " chars from first string, " +++                                      show (length r2) ++ " chars from second string")+                   in prefix +++ cs +++ suffix+               Nothing ->+                   case cont of+                     Just (r1, r2) ->+                         loop (skipped1 + length start1, skipped2 + length start2) (r1, r2)+                     Nothing -> emptyColorString++singleLineDiff' :: DiffConfig -> String -> String -> Maybe ColorString+singleLineDiff' dc s1 s2+    | s1 == s2 = Nothing     | otherwise =         let groups = D.getGroupedDiff s1 s2-        in foldr (\(group, pos) string ->+        in Just $+           foldr (\(group, pos) string ->                       (showDiffGroup pos group) +++                       (if not (isLast pos) then dc_sep dc else emptyColorString) +++                       string)@@ -187,7 +225,13 @@ -} multiLineDiffHaskell :: String -> String -> ColorString multiLineDiffHaskell left right =-    noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right) -- this code is now part of the Diff library (hence the >0.3 in Cabal)+    if length left > maxLen || length right > maxLen+    then noColor+             ("Refusing to compute a multiline diff for strings with more than " ++ show maxLen +++              " chars. Please install the 'diff' tool to get a diff ouput.")+    else noColor $ ppDiff $ D.getGroupedDiff (lines left) (lines right)+    where+      maxLen = 10000  main =     do args <- getArgs

@@ -134,6 +134,7 @@ import Test.Framework.PrettyHaskell  import qualified Data.Text as T+import qualified Data.List as List  -- WARNING: do not forget to add a preprocessor macro for new assertions!! @@ -248,8 +249,8 @@         expected_ = colorize firstDiffColor "* expected:"         but_got_ = colorize secondDiffColor "* but got:"         diff_ = colorize diffColor "* diff:"-    in ("\n" +++ expected_ +++ " " +++ noColor (withNewline exp) +++-        "\n" +++ but_got_ +++ "  " +++ noColor (withNewline act) ++++    in ("\n" +++ expected_ +++ " " +++ noColor (withNewline (trim exp)) ++++        "\n" +++ but_got_ +++ "  " +++ noColor (withNewline (trim act)) +++         "\n" +++ diff_ +++ "     " +++ newlineBeforeDiff diff +++ diff +++         (if (exp == act)          then "\nWARNING: strings are equal but actual values differ!"@@ -265,6 +266,13 @@                       Just _ -> "\n"                       Nothing -> ""           in noColor' (f True) (f False)+      trim s =+          case List.splitAt maxLen s of+            (_, []) -> s+            (prefix, rest) ->+                prefix ++ " (removed " ++ show (length rest) ++ " trailing chars)"+      maxLen = 100000+  equalityFailedMessage :: (Show a) => a -> a -> ColorString equalityFailedMessage exp act =

@@ -24,7 +24,7 @@  module Test.Framework.Preprocessor ( -    transform, progName, preprocessorTests+    transform, progName, preprocessorTests, TransformOptions(..)  ) where @@ -396,8 +396,12 @@       boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell     } -transform :: Bool -> Bool -> FilePath -> String -> IO String-transform hunitBackwardsCompat debug originalFileName input =+data TransformOptions = TransformOptions { hunitBackwardsCompat :: Bool+                                         , debug :: Bool+                                         , literateTex :: Bool }++transform :: TransformOptions -> FilePath -> String -> IO String+transform (TransformOptions hunitBackwardsCompat debug literateTex) originalFileName input =     do (info, toks, pass1) <- analyze originalFileName fixedInput        preprocess info toks pass1     where@@ -408,7 +412,7 @@              let opts = mkOptionsForModule info              preProcessedInput <-                  runCpphsPass2 (boolopts opts) (defines opts) originalFileName pass1-             return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"+             return $ preProcessedInput ++ "\n\n" ++ possiblyWrap literateTex (additionalCode info) ++ "\n"       -- fixedInput serves two purposes:       -- 1. add a trailing \n       -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'@@ -428,6 +432,8 @@                                     nameDefines info                               , boolopts = (boolopts defaultCpphsOptions) { lang = True } -- lex as haskell                               }+      possiblyWrap :: Bool -> String -> String+      possiblyWrap b s = if b then "\\begin{code}\n" ++ s ++ "\\end{code}" else s       additionalCode :: ModuleInfo -> String       additionalCode info =           thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++

@@ -419,6 +419,8 @@             _ -> return ()       storeHistory file history =           BS.writeFile file (serializeTestHistory history)+          `Exc.catch` (\(e::Exc.IOException) ->+                          hPutStrLn stderr ("Error storing HTF history into file " ++ file ++ ": " ++ show e))  -- | Runs something testable with the given 'TestConfig'. -- The result is 'ExitSuccess' if all tests were executed successfully,

@@ -53,7 +53,7 @@  parallelThreadPool :: MonadIO m => Int -> m (ThreadPool m a b) parallelThreadPool n =-    do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+    do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n))        return (ThreadPool (runParallel n))  runSequentially :: MonadIO m => [ThreadPoolEntry m a b] -> m ()@@ -90,7 +90,7 @@ runParallel :: forall m a b . MonadIO m => Int -> [ThreadPoolEntry m a b] -> m () runParallel _ [] = return () runParallel n entries =-    do when (n < 1) $ fail ("invalid number of workers: " ++ show n)+    do when (n < 1) $ liftIO (fail ("invalid number of workers: " ++ show n))        fromWorker <- liftIO $ newNamedChan "fromWorker"        let nWorkers = min n (length entries)        toWorkers <- mapM (\i -> liftIO $ mkWorker i fromWorker) [1..nWorkers]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} -- -- Copyright (c) 2005, 2012   Stefan Wehr - http://www.stefanwehr.de@@ -119,7 +120,11 @@                               (s'',ys) <- mapAccumLM f s' xs                               return (s'',y:ys) +#if !(MIN_VERSION_base(4,13,0)) readM :: (Monad m, Read a) => String -> m a+#else+readM :: (MonadFail m, Read a) => String -> m a+#endif readM s | [x] <- parse = return x         | otherwise    = fail $ "Failed parse: " ++ show s     where

@@ -24,10 +24,16 @@     eval yaml="$yaml" # evaluate variables contained in $yaml     echo >&2 "Checking with $yaml ..."     export HTF_TRAVIS_STACK_ARGS="--stack-yaml $yaml"+    stack $HTF_TRAVIS_STACK_ARGS build+    ecode=$?+    if [ $ecode -ne 0 ]; then+        echo >&2 "Build for $yaml failed!"+        exit 1+    fi     stack $HTF_TRAVIS_STACK_ARGS test     ecode=$?     if [ $ecode -ne 0 ]; then-        echo >&2 "Check for $yaml failed!"+        echo >&2 "Test for $yaml failed!"         exit 1     fi done

@@ -22,15 +22,6 @@ fi  if [ -z "$bin" ]; then-    echo "No executable named htfpp found in $TOP/$dist, trying to build it" >&2-    stack $HTF_TRAVIS_STACK_ARGS build 2> /dev/null > /dev/null-    find_bin-    if [ -z "$bin" ]; then-        echo "Still no executable named htfpp found in $TOP/$dist (even after trying to build it)" >&2-        echo "TOP=$TOP" >&2-        echo "dist=$dist" >&2-        find "$TOP/$dist" -type f >&2-        exit 1-    fi+    echo "No executable named htfpp found in $TOP/$dist. Aborting!" >&2 fi "$bin" "$@"

@@ -1,5 +0,0 @@-resolver: lts-6.35-flags: {}-packages:-- '.'-extra-deps: []

@@ -1,4 +1,4 @@-resolver: nightly-2018-11-06+resolver: lts-14.3 flags: {} packages: - '.'

@@ -0,0 +1,7 @@+resolver: nightly-2019-11-05+flags: {}+packages:+- '.'+extra-deps:+- git: https://github.com/skogsbaer/haskell-src.git+  commit: ab0e6f8bf004337792365cdc53dc1068eaf51eda

@@ -1,4 +1,4 @@-resolver: lts-12.17+resolver: lts-14.3 flags: {} packages: - '.'

@@ -431,5 +431,3 @@                      `onException` (do s <- readFile outFile                                        hPutStrLn stderr s)                 runRealBlackBoxTests-                ecode <- system (dirPrefix </> "compile-errors/run-tests.sh")-                exitWith ecode

@@ -6,18 +6,23 @@ function check() {     test="$1"+    echo "Running test $test ..."     command -v grep >/dev/null 2>&1 || \         { echo >&2 "Test $0 requires ``grep'' but it's not installed.  Aborting."; exit 1; }-    compile_cmd="stack $HTF_TRAVIS_STACK_ARGS ghc -- -XPackageImports $test"-    $compile_cmd 2>&1 | grep "$test":$lineno+    compile_cmd="stack $HTF_TRAVIS_STACK_ARGS ghc --package HTF -- -XPackageImports $test"+    $compile_cmd 2>&1 | grep "$test":$lineno > /dev/null     grep_ecode=${PIPESTATUS[1]}     if [ "$grep_ecode" != "0" ]     then         echo "Compile error for $test did not occur in line $lineno, exit code of grep: ${grep_ecode}"+        echo "Compile command: $compile_cmd"+        echo "Stack version: $(stack --version)"+        echo "GHC version: $(stack $HTF_TRAVIS_STACK_ARGS ghc -- --version)"         echo "Here is the output of the compiler:"         $compile_cmd         exit 1     fi+    echo "Done with test $test" }  check Test1.hs