diff --git a/hspec-core/src/Test/Hspec/Core/Config/Definition.hs b/hspec-core/src/Test/Hspec/Core/Config/Definition.hs --- a/hspec-core/src/Test/Hspec/Core/Config/Definition.hs +++ b/hspec-core/src/Test/Hspec/Core/Config/Definition.hs @@ -62,6 +62,7 @@ , configColorMode :: ColorMode , configUnicodeMode :: UnicodeMode , configDiff :: Bool +, configPrettyPrint :: Bool , configTimes :: Bool , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] , configFormat :: Maybe (FormatConfig -> IO Format) @@ -94,6 +95,7 @@ , configColorMode = ColorAuto , configUnicodeMode = UnicodeAuto , configDiff = True +, configPrettyPrint = True , configTimes = False , configAvailableFormatters = map (fmap V2.formatterToFormat) [ ("checks", V2.checks) @@ -132,6 +134,7 @@ , mkFlag "color" setColor "colorize the output" , mkFlag "unicode" setUnicode "output unicode" , mkFlag "diff" setDiff "show colorized diffs" + , mkFlag "pretty" setPretty "try to pretty-print diff values" , mkFlag "times" setTimes "report times for individual spec items" , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary" , printSlowItemsOption @@ -160,6 +163,9 @@ setDiff :: Bool -> Config -> Config setDiff v config = config {configDiff = v} + + setPretty :: Bool -> Config -> Config + setPretty v config = config {configPrettyPrint = v} setTimes :: Bool -> Config -> Config setTimes v config = config {configTimes = v} diff --git a/hspec-core/src/Test/Hspec/Core/Format.hs b/hspec-core/src/Test/Hspec/Core/Format.hs --- a/hspec-core/src/Test/Hspec/Core/Format.hs +++ b/hspec-core/src/Test/Hspec/Core/Format.hs @@ -59,6 +59,7 @@ formatConfigUseColor :: Bool , formatConfigOutputUnicode :: Bool , formatConfigUseDiff :: Bool +, formatConfigPrettyPrint :: Bool , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs @@ -2,25 +2,55 @@ {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff ( Diff (..) +, recover , diff #ifdef TEST +, recoverString , partition , breakList #endif ) where import Prelude () -import Test.Hspec.Core.Compat +import Control.Arrow +import Test.Hspec.Core.Compat hiding (First) import Data.Char -import Data.Algorithm.Diff +import qualified Data.Algorithm.Diff as Diff +import Text.Show.Unicode (urecover) -diff :: String -> String -> [Diff String] -diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual) +data Diff = First String | Second String | Both String + deriving (Eq, Show) +recover :: Bool -> String -> String -> (String, String) +recover unicode expected actual = case (recoverString unicode expected, recoverString unicode actual) of + (Just expected_, Just actual_) -> (expected_, actual_) + _ -> (rec expected, rec actual) + where + rec = if unicode then urecover else id + +recoverString :: Bool -> String -> Maybe String +recoverString unicode input = case readMaybe input of + Just r | shouldParseBack r -> Just r + _ -> Nothing + where + shouldParseBack = (&&) <$> all isSafe <*> isMultiLine + isMultiLine = lines >>> length >>> (> 1) + isSafe c = (unicode || isAscii c) && (not $ isControl c) || c == '\n' + +diff :: String -> String -> [Diff] +diff expected actual = map (toDiff . fmap concat) $ Diff.getGroupedDiff (partition expected) (partition actual) + +toDiff :: Diff.Diff String -> Diff +toDiff d = case d of + Diff.First xs -> First xs + Diff.Second xs -> Second xs + Diff.Both xs _ -> Both xs + partition :: String -> [String] partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum where + mergeBackslashes :: [String] -> [String] mergeBackslashes xs = case xs of ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs z : zs -> z : mergeBackslashes zs diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs @@ -35,6 +35,7 @@ , outputUnicode , useDiff +, prettyPrint , extraChunk , missingChunk @@ -105,6 +106,10 @@ -- | Return `True` if the user requested colorized diffs, `False` otherwise. useDiff :: FormatM Bool useDiff = getConfig formatConfigUseDiff + +-- | Return `True` if the user requested pretty diffs, `False` otherwise. +prettyPrint :: FormatM Bool +prettyPrint = getConfig formatConfigPrettyPrint -- | Return `True` if the user requested unicode output, `False` otherwise. outputUnicode :: FormatM Bool diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/V1.hs b/hspec-core/src/Test/Hspec/Core/Formatters/V1.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/V1.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/V1.hs @@ -304,14 +304,14 @@ writeDiff chunks extra missing = do withFailColor $ write (indentation ++ "expected: ") forM_ chunks $ \ chunk -> case chunk of - Both a _ -> indented write a + Both a -> indented write a First a -> indented extra a Second _ -> return () writeLine "" withFailColor $ write (indentation ++ " but got: ") forM_ chunks $ \ chunk -> case chunk of - Both a _ -> indented write a + Both a -> indented write a First _ -> return () Second a -> indented missing a writeLine "" diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs b/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs @@ -58,22 +58,31 @@ , outputUnicode , useDiff +, prettyPrint , extraChunk , missingChunk -- ** Helpers , formatLocation , formatException + +#ifdef TEST +, Chunk(..) +, ColorChunk(..) +, indentChunks +#endif ) where import Prelude () import Test.Hspec.Core.Compat hiding (First) +import Data.Char import Data.Maybe import Test.Hspec.Core.Util import Test.Hspec.Core.Clock import Test.Hspec.Core.Spec (Location(..)) import Text.Printf +import Text.Show.Unicode (ushow) import Control.Monad.IO.Class import Control.Exception @@ -116,6 +125,7 @@ , outputUnicode , useDiff + , prettyPrint , extraChunk , missingChunk ) @@ -255,6 +265,7 @@ where formatFailure :: (Int, FailureRecord) -> FormatM () formatFailure (n, FailureRecord mLoc path reason) = do + unicode <- outputUnicode forM_ mLoc $ \loc -> do withInfoColor $ writeLine (" " ++ formatLocation loc) write (" " ++ show n ++ ") ") @@ -262,7 +273,13 @@ case reason of NoReason -> return () Reason err -> withFailColor $ indent err - ExpectedButGot preface expected actual -> do + ExpectedButGot preface expected_ actual_ -> do + pretty <- prettyPrint + let + (expected, actual) + | pretty = recover unicode expected_ actual_ + | otherwise = (expected_, actual_) + mapM_ indent preface b <- useDiff @@ -279,34 +296,77 @@ Nothing -> do writeDiff [First expected, Second actual] write write where - indented output text = case break (== '\n') text of - (xs, "") -> output xs - (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys - writeDiff chunks extra missing = do - withFailColor $ write (indentation ++ "expected: ") - forM_ chunks $ \ chunk -> case chunk of - Both a _ -> indented write a - First a -> indented extra a - Second _ -> return () - writeLine "" + writeChunks "expected: " (expectedChunks chunks) extra + writeChunks " but got: " (actualChunks chunks) missing - withFailColor $ write (indentation ++ " but got: ") - forM_ chunks $ \ chunk -> case chunk of - Both a _ -> indented write a - First _ -> return () - Second a -> indented missing a + writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM () + writeChunks pre chunks colorize = do + withFailColor $ write (indentation ++ pre) + forM_ (indentChunks indentation_ chunks) $ \ chunk -> case chunk of + PlainChunk a -> write a + ColorChunk a -> colorize a writeLine "" + where + indentation_ = indentation ++ replicate (length pre) ' ' Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e writeLine "" - writeLine (" To rerun use: --match " ++ show (joinPath path)) + + let path_ = (if unicode then ushow else show) (joinPath path) + writeLine (" To rerun use: --match " ++ path_) where indentation = " " indent message = do forM_ (lines message) $ \line -> do writeLine (indentation ++ line) + +data Chunk = Original String | Modified String + deriving (Eq, Show) + +expectedChunks :: [Diff] -> [Chunk] +expectedChunks = mapMaybe $ \ chunk -> case chunk of + Both a -> Just $ Original a + First a -> Just $ Modified a + Second _ -> Nothing + +actualChunks :: [Diff] -> [Chunk] +actualChunks = mapMaybe $ \ chunk -> case chunk of + Both a -> Just $ Original a + First _ -> Nothing + Second a -> Just $ Modified a + +data ColorChunk = PlainChunk String | ColorChunk String + deriving (Eq, Show) + +indentChunks :: String -> [Chunk] -> [ColorChunk] +indentChunks indentation = concatMap $ \ chunk -> case chunk of + Original y -> [indentOriginal indentation y] + Modified y -> indentModified indentation y + +indentOriginal :: String -> String -> ColorChunk +indentOriginal indentation = PlainChunk . go + where + go text = case break (== '\n') text of + (xs, _ : ys) -> xs ++ "\n" ++ indentation ++ go ys + (xs, "") -> xs + +indentModified :: String -> String -> [ColorChunk] +indentModified indentation = go + where + go text = case text of + "\n" -> [PlainChunk "\n", ColorChunk indentation] + '\n' : ys@('\n' : _) -> PlainChunk "\n" : ColorChunk indentation : go ys + _ -> case break (== '\n') text of + (xs, _ : ys) -> segment xs ++ PlainChunk ('\n' : indentation) : go ys + (xs, "") -> segment xs + + segment xs = case span isSpace $ reverse xs of + ("", "") -> [] + ("", _) -> [ColorChunk xs] + (_, "") -> [ColorChunk xs] + (ys, zs) -> [ColorChunk (reverse zs), ColorChunk (reverse ys)] defaultFooter :: FormatM () defaultFooter = do diff --git a/hspec-core/src/Test/Hspec/Core/Runner.hs b/hspec-core/src/Test/Hspec/Core/Runner.hs --- a/hspec-core/src/Test/Hspec/Core/Runner.hs +++ b/hspec-core/src/Test/Hspec/Core/Runner.hs @@ -223,6 +223,7 @@ formatConfigUseColor = useColor , formatConfigOutputUnicode = outputUnicode , formatConfigUseDiff = configDiff config + , formatConfigPrettyPrint = configPrettyPrint config , formatConfigPrintTimes = configTimes config , formatConfigHtmlOutput = configHtmlOutput config , formatConfigPrintCpuTime = configPrintCpuTime config diff --git a/hspec-core/src/Test/Hspec/Core/Util.hs b/hspec-core/src/Test/Hspec/Core/Util.hs --- a/hspec-core/src/Test/Hspec/Core/Util.hs +++ b/hspec-core/src/Test/Hspec/Core/Util.hs @@ -11,7 +11,7 @@ , formatRequirement , filterPredicate --- * Working with exception +-- * Working with exceptions , safeTry , formatException ) where diff --git a/hspec-core/vendor/Text/Show/Unicode.hs b/hspec-core/vendor/Text/Show/Unicode.hs new file mode 100644 --- /dev/null +++ b/hspec-core/vendor/Text/Show/Unicode.hs @@ -0,0 +1,140 @@ +{- | +Copyright : (c) Takayuki Muranushi, 2016 +License : BSD3 +Maintainer : whosekiteneverfly@gmail.com +Stability : experimental + + +Provides a interactive printer for printing Unicode characters in ghci REPL. Our design goal is that 'uprint' produces String representations that are valid Haskell 'String' literals and uses as many Unicode printable characters as possible. Hence + +@ +read . ushow == id +@ + +see the tests of this package for detailed specifications. + +__Example__ + +With 'print' : + +@ +$ __ghci__ +... +> __["哈斯克尔7.6.1"]__ +["\\21704\\26031\\20811\\23572\\&7.6.1"] +> +@ + +With 'uprint' : + +@ +$ __ghci -interactive-print=Text.Show.Unicode.uprint Text.Show.Unicode__ +... +Ok, modules loaded: Text.Show.Unicode. +> __("Хорошо!",["哈斯克尔7.6.1的力量","感じる"])__ +("Хорошо!",["哈斯克尔7.6.1的力量","感じる"]) +> "改\\n行" +"改\\n行" +@ + +You can make 'uprint' the default interactive printer in several ways. One is to +@cabal install unicode-show@, and add the following lines to your @~/.ghci@ config file. + +@ +import qualified Text.Show.Unicode +:set -interactive-print=Text.Show.Unicode.uprint +@ + +-} + +module Text.Show.Unicode (ushow, uprint, urecover, ushowWith, uprintWith, urecoverWith) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (many, (<*>), (*>), (<*)) + +import Data.Char (isAscii, isPrint) +import Text.ParserCombinators.ReadP +import Text.Read.Lex (lexChar) +import qualified Data.List as L + +infixl 4 <* + +(<*) :: Monad m => m a -> m b -> m a +(<*) = flip (>>) + +-- Represents a replaced character using its literal form and its escaped form. +type Replacement = (String, String) + +-- | Parse one Haskell character literal expression from a 'String' produced by 'show', and +-- +-- * If the found char satisfies the predicate, replace the literal string with the character itself. +-- * Otherwise, leave the string as it was. +-- * Note that special delimiter sequence "\&" may appear in a string. c.f. . +recoverChar :: (Char -> Bool) -> ReadP Replacement +recoverChar p = represent <$> gather lexCharAndConsumeEmpties + where + represent :: (String, Char) -> Replacement + represent (o,lc) + -- This is too dirty a hack. + -- However, I couldn't think of any other way to recover the & consumed by lexChar while not needlessly increasing the number of & by mis-detecting the escape sequence. + | p lc = + if head o /= '\\' && + "\\&" `L.isSuffixOf` o + then (o, lc : "\\&") + else (o, [lc]) + | otherwise = (o, o) + +-- | The base library lexChar has been handling & by itself since 4.9.1.0, +-- so consumeEmpties is a meaningless action, +-- but it makes sense for older versions of lexChar. +lexCharAndConsumeEmpties :: ReadP Char +lexCharAndConsumeEmpties = lexChar <* consumeEmpties + where + -- Consumes the string "\&" repeatedly and greedily (will only produce one match) + consumeEmpties :: ReadP () + consumeEmpties = do + rest <- look + case rest of + ('\\':'&':_) -> string "\\&" >> consumeEmpties + _ -> return () + +-- | Show the input, and then replace Haskell character literals +-- with the character it represents, for any Unicode printable characters except backslash, single and double quotation marks. +-- If something fails, fallback to standard 'show'. +ushow :: Show a => a -> String +ushow = ushowWith shouldRecover + +-- | Replace Haskell character literals with the character it represents, for +-- any Unicode printable characters except backslash, single and double +-- quotation marks. +urecover :: String -> String +urecover = urecoverWith shouldRecover + +shouldRecover :: Char -> Bool +shouldRecover c = isPrint c && not (isAscii c) + +-- | A version of 'print' that uses 'ushow'. +uprint :: Show a => a -> IO () +uprint = putStrLn . ushow + +-- | Show the input, and then replace character literals +-- with the character itself, for characters that satisfy the given predicate. +ushowWith :: Show a => (Char -> Bool) -> a -> String +ushowWith p = urecoverWith p . show + +-- | Replace character literals with the character itself, for characters that +-- satisfy the given predicate. +urecoverWith :: (Char -> Bool) -> String -> String +urecoverWith p = go ("", "") . readP_to_S (many $ recoverChar p) + where + go :: Replacement -> [([Replacement], String)] -> String + go _ [] = "" + go _ (([],""):_) = "" + go _ ((rs,""):_) = snd $ last rs + go _ [(_,o)] = o + go pr (([],_):rest) = go pr rest + go _ ((rs,_):rest) = let r = last rs in snd r ++ go r rest + +-- | A version of 'print' that uses 'ushowWith'. +uprintWith :: Show a => (Char -> Bool) -> a -> IO () +uprintWith p = putStrLn . ushowWith p diff --git a/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hspec-meta -version: 2.9.0.1 +version: 2.9.2 synopsis: A version of Hspec which is used to test Hspec itself description: A stable version of Hspec which is used to test the in-development version of Hspec. @@ -71,6 +71,7 @@ Test.Hspec.Core.Util Control.Concurrent.Async Data.Algorithm.Diff + Text.Show.Unicode Test.HUnit Test.HUnit.Base Test.HUnit.Lang diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,1 +1,1 @@ -&version 2.9.0.1 +&version 2.9.2