tasty-silver 3.0.1.0 → 3.0.2.0

raw patch · 5 files changed

+605/−99 lines, 5 filesdep +ansi-terminaldep +arraydep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, array, stm

API changes (from Hackage documentation)

Files

• Test/Tasty/Silver.hs +1/−3
• Test/Tasty/Silver/Interactive.hs +516/−71
• Test/Tasty/Silver/Interactive/Run.hs +31/−0
• Test/Tasty/Silver/Internal.hs +42/−14
• tasty-silver.cabal +15/−11

@@ -66,8 +66,6 @@ import qualified Data.Set as Set import Control.Monad --- trick to avoid an explicit dependency on transformers-import Control.Monad.Error (liftIO) import Data.Text.Encoding  @@ -115,7 +113,7 @@   goldenTest1     name     (maybe Nothing (Just . decodeUtf8) <$> readFileMaybe ref)-    (liftIO (toTxt <$> act))+    (toTxt <$> act)     textLikeDiff     textLikeShow     (upd . BL.fromStrict . encodeUtf8)

@@ -1,4 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE BangPatterns #-} -- | Golden test management, interactive mode. Runs the tests, and asks -- the user how to proceed in case of failure or missing golden standard. module Test.Tasty.Silver.Interactive@@ -15,16 +19,25 @@   )   where +import Prelude hiding (fail) import Test.Tasty hiding (defaultMain) import Test.Tasty.Runners import Test.Tasty.Options import Test.Tasty.Silver.Internal+import Test.Tasty.Silver.Interactive.Run import Data.Typeable import Data.Tagged-import Data.Proxy import Data.Maybe-import Control.Monad.Cont-import Control.Monad.State+import Data.Monoid+import Data.Foldable (foldMap)+import Data.Char+import qualified Data.IntMap as IntMap+import Control.Monad.State hiding (fail)+import Control.Monad.STM+import Control.Monad.Reader hiding (fail)+import Control.Monad.Identity hiding (fail)+import Control.Concurrent.STM.TVar+import Control.Exception import Text.Printf import qualified Data.Text as T import Data.Text.Encoding@@ -36,6 +49,9 @@ import System.IO import System.IO.Temp import System.FilePath+import Test.Tasty.Providers+import qualified Data.Map as M+import System.Console.ANSI  -- | Like @defaultMain@ from the main tasty package, but also includes the -- golden test management capabilities.@@ -49,92 +65,85 @@   parseValue = fmap Interactive . safeRead   optionName = return "interactive"   optionHelp = return "Run tests in interactive mode."-  optionCLParser =-    fmap Interactive $-    switch-      (  long (untag (optionName :: Tagged Interactive String))-      <> help (untag (optionHelp :: Tagged Interactive String))-      )+  optionCLParser = flagCLParser (Just 'i') (Interactive True)  +data ResultStatus = RPass | RFail | RInteract GoldenResultI +type GoldenStatus = GoldenResultI++type GoldenStatusMap = TVar (M.Map TestName GoldenStatus)+ interactiveTests :: Ingredient interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $   \opts tree ->-    case lookupOption opts of-      Interactive False -> Nothing-      Interactive True -> Just $-        runTestsInteractive opts tree+      case lookupOption opts of+        Interactive False -> Nothing+        Interactive True -> Just $+          runTestsInteractive opts tree --- | Get the list of all golden tests in a given test tree-getGoldenTests :: OptionSet -> TestTree -> [(TestName, Golden)]-getGoldenTests =-  foldTestTree-    trivialFold { foldSingle = \_ name t -> fmap ((,) name) $ maybeToList $ cast t } --- | Run in interactive mode (only tested on linux)+runSingleTest ::  IsTest t => GoldenStatusMap -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result+runSingleTest gs n opts t cb = do+  case (cast t :: Maybe Golden) of+    Nothing -> run opts t cb+    Just g -> do++        (r, gr) <- runGolden g++        -- we may be in a different thread here than the main ui.+        -- force evaluation of actual value here, as we have to evaluate it before+        -- leaving this test.+        gr' <- forceGoldenResult gr+        atomically $ modifyTVar gs (M.insert n gr')+        return r+++-- | A simple console UI runTestsInteractive :: OptionSet -> TestTree -> IO Bool runTestsInteractive opts tests = do-  let gs = getGoldenTests opts tests+  gmap <- newTVarIO M.empty+  let tests' = wrapRunTest (runSingleTest gmap) tests -  liftIO $ hSetBuffering stdout NoBuffering+  r <- launchTestTree opts tests' $ \smap ->+    do+    isTerm <- hSupportsANSI stdout -  (nFail, nReject) <- flip execStateT (0, 0) $ forM_ gs runTest+    (\k -> if isTerm+      then (do hideCursor; k) `finally` showCursor+      else k) $ do -  -- warn when there were problems-  when (nFail > 0 || nReject > 0) (do-    _ <- printf "NOTE: %d tests threw exceptions!\n" nFail-    printf "NOTE: %d tests were rejected!\n" nReject-    )+      hSetBuffering stdout NoBuffering -  -- is everything ok?-  return (nFail == 0 && nReject == 0)-  where runTest :: (TestName, Golden) -> StateT (Integer, Integer) IO ()-        runTest (n, (Golden getGolden getActual cmp shw upd)) = do-            -- execute test-            liftIO $ putStrLn "Executing test"+      let+        whenColor = lookupOption opts+        HideSuccesses hideSuccesses = lookupOption opts -            -- we can't run any update inside the vg monad,-            -- as the golden file might still be open-            (pFail, pReject, act) <- liftIO $ do-              tested <- getActual+      let+        ?colors = useColor whenColor isTerm -              -- read golden-              liftIO $ putStrLn "Getting golden"-              golden <- getGolden-              case golden of-                Nothing -> do-                  _ <- liftIO $ printf "%s: No golden value. Press <enter> to see actual value.\n" n-                  _ <- liftIO getLine-                  _ <- liftIO $ shw tested >>= showValue n-                  liftIO $ tryAccept n upd tested-                Just golden' -> do-                  cmp' <- liftIO $ cmp golden' tested-                  case cmp' of-                    Equal -> do-                      _ <- liftIO $ printf "%s: Golden value matches output.\n" n-                      return (0, 0, return ())-                    diff' -> do-                      _ <- liftIO $ printf "%s: Output does not match golden value. Press <enter> to see diff.\n" n-                      _ <- liftIO getLine-                      _ <- liftIO $ showDiff n diff'-                      liftIO $ tryAccept n upd tested-            -- now execute update-            liftIO act-            modify (\(nFail, nReject) -> (nFail + pFail, nReject + pReject))+      let+        outp = produceOutput opts tests -        tryAccept :: TestName -> (a -> IO ()) -> a -> IO (Integer, Integer, IO ())-        tryAccept n upd new = do-            _ <- printf "%s: Accept actual value as new golden value? [yn]" n-            ans <- getLine-            case ans of-              "y" -> do-                    return (0, 0, upd new)-              "n" -> return (0, 1, return ())-              _   -> do-                    putStrLn "Invalid answer."-                    tryAccept n upd new+      case () of { _+        | hideSuccesses && isTerm ->+            consoleOutputHidingSuccesses outp smap gmap+        | hideSuccesses && not isTerm ->+            streamOutputHidingSuccesses outp smap gmap+        | otherwise -> consoleOutput outp smap gmap+      } +      return $ \time -> do+            stats <- computeStatistics smap+            printStatistics stats time+            return $ statFailures stats == 0++++  return r+++ showDiff :: TestName -> GDiff -> IO () showDiff n (DiffText _ tGold tAct) = do   withSystemTempFile (n <.> "golden") (\fGold hGold -> do@@ -149,6 +158,7 @@         ["-c", "git diff --color=always --no-index --text " ++ fGold ++ " " ++ fAct ++ " | less -r > /dev/tty"]       )     )+ showDiff n (ShowDiffed _ t) = showInLess n t showDiff _ Equal = error "Can't show diff for equal values..." @@ -161,3 +171,438 @@   _ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp   return ()   where inp = B.fromStrict $ encodeUtf8 t++tryAccept :: String -> TestName -> (a -> IO ()) -> a -> IO Bool+tryAccept pref nm upd new = do+  isTerm <- hSupportsANSI stdout+  when isTerm showCursor+  _ <- printf "%sAccept actual value as new golden value? [yn] " pref+  ans <- getLine+  case ans of+    "y" -> do+        upd new+        printf "%s" pref+        when isTerm hideCursor+        return True+    "n" -> do+        printf "%s" pref+        when isTerm hideCursor+        return False+    _   -> do+        printf "%sInvalid answer.\n" pref+        tryAccept pref nm upd new+++--------------------------------------------------+-- TestOutput base definitions+--------------------------------------------------+-- {{{+-- | 'TestOutput' is an intermediary between output formatting and output+-- printing. It lets us have several different printing modes (normal; print+-- failures only; quiet).+data TestOutput+  = PrintTest+      {- test name, used for golden lookup #-} (TestName)+      {- print test name   -} (IO ())+      {- print test result -} ((Result, ResultStatus) -> IO ())+  | PrintHeading (IO ()) TestOutput+  | Skip+  | Seq TestOutput TestOutput++-- The monoid laws should hold observationally w.r.t. the semantics defined+-- in this module+instance Monoid TestOutput where+  mempty = Skip+  mappend = Seq++type Level = Int++produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput+produceOutput opts tree =+  let+    -- Do not retain the reference to the tree more than necessary+    !alignment = computeAlignment opts tree++    handleSingleTest+      :: (IsTest t, ?colors :: Bool)+      => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput+    handleSingleTest _opts name _test = Ap $ do+      level <- ask++      let+        align = replicate (alignment - indentSize * level - length name) ' '+        pref = indent level ++ replicate (length name) ' ' ++ "  " ++ align+        printTestName =+          printf "%s%s: %s" (indent level) name align++        printTestResult (result, resultStatus) = do+          result' <- case resultStatus of+            RInteract (GRNoGolden a shw upd) -> do+                printf "Golden value missing. Press <enter> to show actual value.\n"+                _ <- getLine+                let a' = runIdentity a+                shw' <- shw a'+                showValue name shw'+                isUpd <- tryAccept pref name upd a'+                return $ if isUpd then testPassed "Created golden value." else testFailed "Golden value missing."+            RInteract (GRDifferent _ a diff upd) -> do+                printf "Golden value differs from actual value.\n"+                showDiff name diff+                isUpd <- tryAccept pref name upd a+                return $ if isUpd then testPassed "Updated golden value." else testFailed "Golden value does not match actual output."+            _ -> return result+          rDesc <- formatMessage $ resultDescription result'++          -- use an appropriate printing function+          let+            printFn =+              if resultSuccessful result'+                then ok+                else fail+            time = resultTime result+          if resultSuccessful result'+            then printFn "OK"+            else printFn "FAIL"+          -- print time only if it's significant+          when (time >= 0.01) $+            printFn (printf " (%.2fs)" time)+          printFn "\n"++          when (not $ null rDesc) $+            (if resultSuccessful result' then infoOk else infoFail) $+              printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)++      return $ PrintTest name printTestName printTestResult++    handleGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput+    handleGroup name grp = Ap $ do+      level <- ask+      let+        printHeading = printf "%s%s\n" (indent level) name+        printBody = runReader (getApp grp) (level + 1)+      return $ PrintHeading printHeading printBody++  in+    flip runReader 0 $ getApp $+      foldTestTree+        trivialFold+          { foldSingle = handleSingleTest+          , foldGroup = handleGroup+          }+          opts tree++foldTestOutput+  :: (?colors :: Bool, Monoid b)+  => (IO () -> IO (Result, ResultStatus)+    -> ((Result, ResultStatus) -> IO ())+    -> b)+  -> (IO () -> b -> b)+  -> TestOutput -> StatusMap -> GoldenStatusMap -> b+foldTestOutput foldTest foldHeading outputTree smap gmap =+  flip evalState 0 $ getApp $ go outputTree where+  go (PrintTest nm printName printResult) = Ap $ do+    ix <- get+    put $! ix + 1+    let+      readStatusVar = getResultWithGolden smap gmap nm ix+    return $ foldTest printName readStatusVar printResult+  go (PrintHeading printName printBody) = Ap $+    foldHeading printName <$> getApp (go printBody)+  go (Seq a b) = mappend (go a) (go b)+  go Skip = mempty++-- }}}++--------------------------------------------------+-- TestOutput modes+--------------------------------------------------+-- {{{+consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+consoleOutput outp smap gmap =+  getTraversal . fst $ foldTestOutput foldTest foldHeading outp smap gmap+  where+    foldTest printName getResult printResult =+      ( Traversal $ do+          _ <- printName+          r <- getResult+          printResult r+      , Any True)+    foldHeading printHeading (printBody, Any nonempty) =+      ( Traversal $ do+          when nonempty $ printHeading >> getTraversal printBody+      , Any nonempty+      )++consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+consoleOutputHidingSuccesses outp smap gmap =+  void . getApp $ foldTestOutput foldTest foldHeading outp smap gmap+  where+    foldTest printName getResult printResult =+      Ap $ do+          _ <- printName+          r <- getResult+          if resultSuccessful (fst r)+            then clearThisLine >> (return $ Any False)+            else printResult r >> (return $ Any True)++    foldHeading printHeading printBody =+      Ap $ do+        _ <- printHeading+        Any failed <- getApp printBody+        unless failed clearAboveLine+        return $ Any failed++    clearAboveLine = do cursorUpLine 1; clearThisLine+    clearThisLine = do clearLine; setCursorColumn 0++streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO ()+streamOutputHidingSuccesses outp smap gmap =+  void . flip evalStateT [] . getApp $+    foldTestOutput foldTest foldHeading outp smap gmap+  where+    foldTest printName getResult printResult =+      Ap $ do+          r <- liftIO $ getResult+          if resultSuccessful (fst r)+            then return $ Any False+            else do+              stack <- get+              put []++              _ <- liftIO $ do+                sequence_ $ reverse stack+                _ <- printName+                printResult r++              return $ Any True++    foldHeading printHeading printBody =+      Ap $ do+        modify (printHeading :)+        Any failed <- getApp printBody+        unless failed $+          modify $ \stack ->+            case stack of+              _:rest -> rest+              [] -> [] -- shouldn't happen anyway+        return $ Any failed++-- }}}++--------------------------------------------------+-- Statistics+--------------------------------------------------+-- {{{++data Statistics = Statistics+  { statTotal :: !Int+  , statFailures :: !Int+  }++instance Monoid Statistics where+  Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2)+  mempty = Statistics 0 0++computeStatistics :: StatusMap -> IO Statistics+computeStatistics = getApp . foldMap (\var -> Ap $+  (\r -> Statistics 1 (if resultSuccessful r then 0 else 1))+    <$> getResultFromTVar var)++printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()+printStatistics st time = do+  printf "\n"++  case statFailures st of+    0 -> do+      ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time++    fs -> do+      fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time++data FailureStatus+  = Unknown+  | Failed+  | OK++instance Monoid FailureStatus where+  mappend Failed _ = Failed+  mappend _ Failed = Failed++  mappend OK OK = OK++  mappend _ _ = Unknown++  mempty = OK++-- }}}++--------------------------------------------------+-- Console test reporter+--------------------------------------------------++-- | Report only failed tests+newtype HideSuccesses = HideSuccesses Bool+  deriving (Eq, Ord, Typeable)+instance IsOption HideSuccesses where+  defaultValue = HideSuccesses False+  parseValue = fmap HideSuccesses . safeRead+  optionName = return "hide-successes"+  optionHelp = return "Do not print tests that passed successfully"+  optionCLParser = flagCLParser Nothing (HideSuccesses True)++-- | When to use color on the output+data UseColor+  = Never | Always | Auto+  deriving (Eq, Ord, Typeable)++-- | Control color output+instance IsOption UseColor where+  defaultValue = Auto+  parseValue = parseUseColor+  optionName = return "color"+  optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')"+  optionCLParser =+    option parse+      (  long name+      <> help (untag (optionHelp :: Tagged UseColor String))+      )+    where+      name = untag (optionName :: Tagged UseColor String)+      parse = str >>=+        maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue++-- | @useColor when isTerm@ decides if colors should be used,+--   where @isTerm@ denotes where @stdout@ is a terminal device.+useColor :: UseColor -> Bool -> Bool+useColor cond isTerm =+  case cond of+    Never  -> False+    Always -> True+    Auto   -> isTerm++parseUseColor :: String -> Maybe UseColor+parseUseColor s =+  case map toLower s of+    "never"  -> return Never+    "always" -> return Always+    "auto"   -> return Auto+    _        -> Nothing++-- }}}++--------------------------------------------------+-- Various utilities+--------------------------------------------------+-- {{{++getResultWithGolden :: StatusMap -> GoldenStatusMap -> TestName -> Int -> IO (Result, ResultStatus)+getResultWithGolden smap gmap nm ix = do+  r <- getResultFromTVar statusVar++  gr <- atomically $ readTVar gmap+  case nm `M.lookup` gr of+    Just g@(GRDifferent {}) -> return (r, RInteract g)+    Just g@(GRNoGolden {})  -> return (r, RInteract g)+    _ | resultSuccessful r  -> return (r, RPass)+    _ | otherwise           -> return (r, RFail)+  where statusVar =+            fromMaybe (error "internal error: index out of bounds") $+            IntMap.lookup ix smap++getResultFromTVar :: TVar Status -> IO Result+getResultFromTVar statusVar = do+  atomically $ do+    status <- readTVar statusVar+    case status of+      Done r -> return r+      _ -> retry++-- }}}++--------------------------------------------------+-- Formatting+--------------------------------------------------+-- {{{++indentSize :: Int+indentSize = 2++indent :: Int -> String+indent n = replicate (indentSize * n) ' '++-- handle multi-line result descriptions properly+formatDesc+  :: Int -- indent+  -> String+  -> String+formatDesc n desc =+  let+    -- remove all trailing linebreaks+    chomped = reverse . dropWhile (== '\n') . reverse $ desc++    multiline = '\n' `elem` chomped++    -- we add a leading linebreak to the description, to start it on a new+    -- line and add an indentation+    paddedDesc = flip concatMap chomped $ \c ->+      if c == '\n'+        then c : indent n+        else [c]+  in+    if multiline+      then paddedDesc+      else chomped++data Maximum a+  = Maximum a+  | MinusInfinity++instance Ord a => Monoid (Maximum a) where+  mempty = MinusInfinity++  Maximum a `mappend` Maximum b = Maximum (a `max` b)+  MinusInfinity `mappend` a = a+  a `mappend` MinusInfinity = a++-- | Compute the amount of space needed to align "OK"s and "FAIL"s+computeAlignment :: OptionSet -> TestTree -> Int+computeAlignment opts =+  fromMonoid .+  foldTestTree+    trivialFold+      { foldSingle = \_ name _ level -> Maximum (length name + level)+      , foldGroup = \_ m -> m . (+ indentSize)+      }+    opts+  where+    fromMonoid m =+      case m 0 of+        MinusInfinity -> 0+        Maximum x -> x++-- (Potentially) colorful output+ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()+fail     = output BoldIntensity   Vivid Red+ok       = output NormalIntensity Dull  Green+infoOk   = output NormalIntensity Dull  White+infoFail = output NormalIntensity Dull  Red++output+  :: (?colors :: Bool)+  => ConsoleIntensity+  -> ColorIntensity+  -> Color+  -> String+  -> IO ()+output bold intensity color st+  | ?colors =+    (do+      setSGR+        [ SetColor Foreground intensity color+        , SetConsoleIntensity bold+        ]+      putStr st+    ) `finally` setSGR []+  | otherwise = putStr st++-- }}}

@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+module Test.Tasty.Silver.Interactive.Run+  ( wrapRunTest+  )+  where++import Test.Tasty hiding (defaultMain)+import Test.Tasty.Runners+import Test.Tasty.Options+import Data.Typeable+import Data.Tagged+import Test.Tasty.Providers++data CustomTestExec t = IsTest t => CustomTestExec t (OptionSet -> t -> (Progress -> IO ()) -> IO Result)+  deriving (Typeable)++instance IsTest t => IsTest (CustomTestExec t) where+  run opts (CustomTestExec t r) cb = r opts t cb+  testOptions = retag $ (testOptions :: Tagged t [OptionDescription])+++-- | Provide new test run function wrapping the existing tests.+wrapRunTest :: (forall t . IsTest t => TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) -> TestTree -> TestTree+wrapRunTest f (SingleTest n t) = SingleTest n (CustomTestExec t (f n))+wrapRunTest f (TestGroup n ts) = TestGroup n (fmap (wrapRunTest f) ts)+wrapRunTest f (PlusTestOptions o t) = PlusTestOptions o (wrapRunTest f t)+wrapRunTest f (WithResource r t) = WithResource r (\x -> wrapRunTest f (t x))+wrapRunTest f (AskOptions t) = AskOptions (\o -> wrapRunTest f (t o))

@@ -4,6 +4,7 @@  import Control.Applicative import Control.Exception+import Control.Monad.Identity import Data.Typeable (Typeable) import Data.ByteString as SB import System.IO.Error@@ -63,26 +64,53 @@   = ShowText T.Text     -- ^ Show the given text.  instance IsTest Golden where-  run opts golden _ = runGolden golden (lookupOption opts)+  run opts golden _ = do+    (r, gr) <- runGolden golden+    let (AcceptTests accept) = lookupOption opts :: AcceptTests+    case gr of+      GRNoGolden act _ upd | accept -> do+            act >>= upd+            return $ testPassed "Created golden file."+      GRDifferent _ act _ upd | accept -> do+            upd act+            return $ testPassed "Updated golden file."+      _ -> return r+   testOptions = return [Option (Proxy :: Proxy AcceptTests)] -runGolden :: Golden -> AcceptTests -> IO Result-runGolden (Golden getGolden getActual cmp _ upd) (AcceptTests accept) = do+type GoldenResult = GoldenResult' IO+type GoldenResultI = GoldenResult' Identity++data GoldenResult' m+  = GREqual+  | forall a . GRDifferent+        (a)     -- golden+        (a)     -- actual+        (GDiff) -- diff+        (a -> IO ()) -- update+  | forall a . GRNoGolden+        (m a) -- compute actual (we don't want to compute it if it is not used)+        (a -> IO GShow) --show+        (a -> IO ()) -- update++runGolden :: Golden -> IO (Result, GoldenResult)+runGolden (Golden getGolden getActual cmp shw upd) = do   ref' <- getGolden   case ref' of-    Nothing | accept -> do-          new <- getActual-          upd new-          return $ testPassed "Created golden file."-    Nothing -> return $ testFailed "Missing golden value."+    Nothing -> return (testFailed "Missing golden value.", GRNoGolden getActual shw upd)     Just ref -> do       new <- getActual       -- Output could be arbitrarily big, so don't even try to say what wen't wrong.       cmp' <- cmp ref new       case cmp' of-        Equal -> return $ testPassed ""-        _ | accept -> do-              upd new-              return $ testPassed "Updated golden file."-        d | isJust (gReason d) -> return $ testFailed $ fromJust $ gReason d-        _ -> return $ testFailed "Result did not match expected output. Use interactive mode to see full output."+        Equal -> return (testPassed "", GREqual)+        d -> let r = fromMaybe "Result did not match expected output. Use interactive mode (-i) to see full output." (gReason d)+              in return (testFailed r, GRDifferent ref new cmp' upd)++forceGoldenResult :: GoldenResult -> IO GoldenResultI+forceGoldenResult gr = case gr of+            (GRNoGolden act shw upd) -> do+                act' <- act+                return $ GRNoGolden (Identity act') shw upd+            (GRDifferent a b c d) -> return $ GRDifferent a b c d+            (GREqual) -> return GREqual

@@ -1,5 +1,5 @@ name:                tasty-silver-version:             3.0.1.0+version:             3.0.2.0 synopsis:            Golden tests support for tasty. Fork of tasty-golden. description:   This package provides support for «golden testing».@@ -30,27 +30,31 @@   exposed-modules:     Test.Tasty.Silver                        Test.Tasty.Silver.Advanced                        Test.Tasty.Silver.Interactive+                       Test.Tasty.Silver.Interactive.Run   other-modules:                        Test.Tasty.Silver.Internal    ghc-options: -Wall    build-depends:+    ansi-terminal >= 0.6.2.1 && < 0.7,+    array >= 0.5.0.0 && <0.6,+    async,     base ==4.*,-    tasty >= 0.8,     bytestring,-    process >= 1.2 && < 1.3,+    containers,+    directory,+    deepseq,+    filepath,     mtl,     optparse-applicative,-    filepath,-    temporary-rc,+    process >= 1.2 && < 1.3,+    process-extras >= 0.2 && < 0.3,+    stm >= 2.4.2 && < 2.5,     tagged,-    deepseq,-    containers,-    directory,-    async,-    text >= 0.11.0.0 && < 1.3,-    process-extras >= 0.2 && < 0.3+    tasty >= 0.8,+    temporary-rc,+    text >= 0.11.0.0 && < 1.3  Test-suite test   Default-language: