tasty-silver 3.0.0.1 → 3.0.1.0

raw patch · 6 files changed

+232/−298 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Test/Tasty/Silver.hs +4/−10
• Test/Tasty/Silver/Advanced.hs +9/−11
• Test/Tasty/Silver/Interactive.hs +163/−0
• Test/Tasty/Silver/Internal.hs +54/−63
• Test/Tasty/Silver/Manage.hs +0/−212
• tasty-silver.cabal +2/−2

@@ -49,7 +49,6 @@    , printProcResult -  , writeBinaryFile   , findByExtension   )   where@@ -66,7 +65,6 @@ import System.FilePath import qualified Data.Set as Set import Control.Monad-import System.IO  -- trick to avoid an explicit dependency on transformers import Control.Monad.Error (liftIO)@@ -83,8 +81,8 @@ goldenVsFile name ref new act =   goldenTest1     name-    (maybe Nothing (Just . decodeUtf8 . BL.toStrict) <$> vgReadFileMaybe ref)-    (liftIO act >> (decodeUtf8 . BL.toStrict <$> vgReadFile new))+    (maybe Nothing (Just . decodeUtf8) <$> readFileMaybe ref)+    (act >> (decodeUtf8 <$> BS.readFile new))     textLikeDiff     textLikeShow     (upd)@@ -116,7 +114,7 @@ goldenVsAction name ref act toTxt =   goldenTest1     name-    (maybe Nothing (Just . decodeUtf8 . BL.toStrict) <$> vgReadFileMaybe ref)+    (maybe Nothing (Just . decodeUtf8) <$> readFileMaybe ref)     (liftIO (toTxt <$> act))     textLikeDiff     textLikeShow@@ -128,7 +126,7 @@  textLikeDiff :: T.Text -> T.Text -> GDiff textLikeDiff x y | x == y    = Equal-textLikeDiff x y | otherwise =  DiffText x y+textLikeDiff x y | otherwise =  DiffText Nothing x y   -- | Converts the output of a process produced by e.g. System.Process.Text to a textual representation.@@ -146,10 +144,6 @@           f pref ln | otherwise = pref `T.append` " " `T.append` ln  ---- | Like 'writeFile', but uses binary mode-writeBinaryFile :: FilePath -> String -> IO ()-writeBinaryFile f txt = withBinaryFile f WriteMode (\hdl -> hPutStr hdl txt)  -- | Find all files in the given directory and its subdirectories that have -- the given extensions.

@@ -9,10 +9,8 @@     GShow (..),     GDiff (..), -    -- * ValueGetter monad-    ValueGetter(..),-    vgReadFile,-    vgReadFileMaybe+    -- * reading files+    readFileMaybe   ) where @@ -24,8 +22,8 @@ -- | A very general testing function. Use 'goldenTest1' instead if you can. goldenTest   :: TestName -- ^ test name-  -> (forall r . ValueGetter r a) -- ^ get the golden correct value-  -> (forall r . ValueGetter r a) -- ^ get the tested value+  -> (IO a) -- ^ get the golden correct value+  -> (IO a) -- ^ get the tested value   -> (a -> a -> IO (Maybe String))     -- ^ comparison function.     --@@ -42,7 +40,7 @@         runCmp a b = do             cmp' <- cmp a b             case cmp' of-                Just d -> return $ ShowDiffed $ T.pack d+                Just d -> return $ ShowDiffed Nothing (T.pack d)                 Nothing -> return Equal         shw _ = return $ ShowText "Old API does not support showing the actual value. Use the --accept mode or use the new API." @@ -50,8 +48,8 @@ -- | A very general testing function. goldenTest1   :: TestName -- ^ test name-  -> (forall r . ValueGetter r (Maybe a)) -- ^ get the golden correct value-  -> (forall r . ValueGetter r a) -- ^ get the tested value+  -> (IO (Maybe a)) -- ^ get the golden correct value+  -> (IO a) -- ^ get the tested value   -> (a -> a -> GDiff)     -- ^ comparison function.     --@@ -68,8 +66,8 @@ -- the `goldenTest1` function should be used instead. goldenTestIO   :: TestName -- ^ test name-  -> (forall r . ValueGetter r (Maybe a)) -- ^ get the golden correct value-  -> (forall r . ValueGetter r a) -- ^ get the tested value+  -> (IO (Maybe a)) -- ^ get the golden correct value+  -> (IO a) -- ^ get the tested value   -> (a -> a -> IO GDiff)     -- ^ comparison function.     --

@@ -0,0 +1,163 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}+-- | 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+  (+  -- * Command line helpers+    defaultMain++  -- * The ingredient+  , interactiveTests+  , Interactive (..)++  -- * Programmatic API+  , runTestsInteractive+  )+  where++import Test.Tasty hiding (defaultMain)+import Test.Tasty.Runners+import Test.Tasty.Options+import Test.Tasty.Silver.Internal+import Data.Typeable+import Data.Tagged+import Data.Proxy+import Data.Maybe+import Control.Monad.Cont+import Control.Monad.State+import Text.Printf+import qualified Data.Text as T+import Data.Text.Encoding+import Options.Applicative+import System.Process.ByteString.Lazy as PL+import System.Process+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as BS+import System.IO+import System.IO.Temp+import System.FilePath++-- | Like @defaultMain@ from the main tasty package, but also includes the+-- golden test management capabilities.+defaultMain :: TestTree -> IO ()+defaultMain = defaultMainWithIngredients [interactiveTests, listingTests, consoleTestReporter]++newtype Interactive = Interactive Bool+  deriving (Eq, Ord, Typeable)+instance IsOption Interactive where+  defaultValue = Interactive False+  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))+      )++++interactiveTests :: Ingredient+interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $+  \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)+runTestsInteractive :: OptionSet -> TestTree -> IO Bool+runTestsInteractive opts tests = do+  let gs = getGoldenTests opts tests++  liftIO $ hSetBuffering stdout NoBuffering++  (nFail, nReject) <- flip execStateT (0, 0) $ forM_ gs runTest++  -- 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+    )++  -- 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"++            -- 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++              -- 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))++        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++showDiff :: TestName -> GDiff -> IO ()+showDiff n (DiffText _ tGold tAct) = do+  withSystemTempFile (n <.> "golden") (\fGold hGold -> do+    withSystemTempFile (n <.> "actual") (\fAct hAct -> do+      hSetBinaryMode hGold True+      hSetBinaryMode hAct True+      BS.hPut hGold (encodeUtf8 tGold)+      BS.hPut hAct (encodeUtf8 tAct)+      hClose hGold+      hClose hAct+      callProcess "sh"+        ["-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..."++showValue :: TestName -> GShow -> IO ()+showValue n (ShowText t) = showInLess n t++showInLess :: String -> T.Text -> IO ()+showInLess _ t = do+  -- TODO error handling...+  _ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp+  return ()+  where inp = B.fromStrict $ encodeUtf8 t

@@ -3,95 +3,86 @@ module Test.Tasty.Silver.Internal where  import Control.Applicative-import Control.Monad.Cont import Control.Exception import Data.Typeable (Typeable)-import Data.ByteString.Lazy as LB-import System.IO+import Data.ByteString as SB import System.IO.Error-import Test.Tasty.Providers import qualified Data.Text as T+import Options.Applicative+import Data.Tagged+import Data.Proxy import Data.Maybe+import Test.Tasty.Providers+import Test.Tasty.Options  -- | See 'goldenTest1' for explanation of the fields data Golden =   forall a .     Golden-        (forall r . ValueGetter r (Maybe a))    -- Get golden value.-        (forall r . ValueGetter r a)            -- Get actual value.+        (IO (Maybe a))    -- Get golden value.+        (IO a)            -- Get actual value.         (a -> a -> IO GDiff)                       -- Compare/diff.         (a -> IO GShow)                            -- How to produce a show.         (a -> IO ())                            -- Update golden value.   deriving Typeable --- | An action that yields a value (either golden or tested).------ CPS allows closing the file handle when using lazy IO to read data.-newtype ValueGetter r a = ValueGetter-  { runValueGetter :: ContT r IO a }-  deriving (Functor, Applicative, Monad, MonadCont, MonadIO) --- | Lazily read a file. The file handle will be closed after the--- 'ValueGetter' action is run.-vgReadFile :: FilePath -> ValueGetter r ByteString-vgReadFile path = fromJust <$> vgReadFile1 predFalse path-  where predFalse :: IOException -> Bool-        predFalse _ = False---- | Lazily read a file. The file handle will be closed after the--- 'ValueGetter' action is run.--- Will return 'Nothing' if the file does not exist.-vgReadFileMaybe :: FilePath -> ValueGetter r (Maybe ByteString)-vgReadFileMaybe = vgReadFile1 (isDoesNotExistErrorType . ioeGetErrorType)----- | Reads a file, and optionally catches some exceptions. If--- an exception is catched, Nothing is returned.-vgReadFile1 :: Exception e-    => (e -> Bool)  -- ^ Which exceptions to catch.-    -> FilePath-    -> ValueGetter r (Maybe ByteString)-vgReadFile1 doCatch path = do-  r <- ValueGetter $-    ContT $ \k ->-    catchJust (\e -> if doCatch e then Just () else Nothing)-      (bracket-        (openBinaryFile path ReadMode)-        hClose-        (\h -> LB.hGetContents h >>= (k . Just))+-- | This option, when set to 'True', specifies that we should run in the+-- «accept tests» mode+newtype AcceptTests = AcceptTests Bool+  deriving (Eq, Ord, Typeable)+instance IsOption AcceptTests where+  defaultValue = AcceptTests False+  parseValue = fmap AcceptTests . safeRead+  optionName = return "accept"+  optionHelp = return "Accept current results of golden tests"+  optionCLParser =+    fmap AcceptTests $+    switch+      (  long (untag (optionName :: Tagged AcceptTests String))+      <> help (untag (optionHelp :: Tagged AcceptTests String))       )-      (const $ k Nothing)-  return $! r --- | Ensures that the result is fully evaluated (so that lazy file handles--- can be closed)-vgRun :: ValueGetter r r -> IO r-vgRun (ValueGetter a) = runContT a evaluate+-- | Read the file if it exists, else return Nothing.+-- Useful for reading golden files.+readFileMaybe :: FilePath -> IO (Maybe SB.ByteString)+readFileMaybe path = catchJust+    (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing)+    (Just <$> SB.readFile path)+    (const $ return Nothing) + -- | The comparison/diff result. data GDiff   = Equal -- ^ Values are equal.-  | DiffText { gActual :: T.Text, gExpected :: T.Text } -- ^ The two values are different, show a diff between the two given texts.-  | ShowDiffed { gDiff :: T.Text }  -- ^ The two values are different, just show the given text to the user.+  | DiffText { gReason :: (Maybe String), gActual :: T.Text, gExpected :: T.Text } -- ^ The two values are different, show a diff between the two given texts.+  | ShowDiffed { gReason :: (Maybe String), gDiff :: T.Text }  -- ^ The two values are different, just show the given text to the user.  -- | How to show a value to the user. data GShow   = ShowText T.Text     -- ^ Show the given text.  instance IsTest Golden where-  run _ golden _ = runGolden golden-  testOptions = return []+  run opts golden _ = runGolden golden (lookupOption opts)+  testOptions = return [Option (Proxy :: Proxy AcceptTests)] -runGolden :: Golden -> IO Result-runGolden (Golden getGolden getActual cmp _ _) = do-  vgRun $ do-    new <- getActual-    ref' <- getGolden-    case ref' of-      Nothing -> return $ testFailed "Missing golden value."-      Just ref -> do-        -- Output could be arbitrarily big, so don't even try to say what wen't wrong.-        cmp' <- liftIO $ cmp ref new-        case cmp' of-          Equal -> return $ testPassed ""-          _     -> return $ testFailed "Result did not match expected output. Use interactive mode to see the full output."+runGolden :: Golden -> AcceptTests -> IO Result+runGolden (Golden getGolden getActual cmp _ upd) (AcceptTests accept) = do+  ref' <- getGolden+  case ref' of+    Nothing | accept -> do+          new <- getActual+          upd new+          return $ testPassed "Created golden file."+    Nothing -> return $ testFailed "Missing golden value."+    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."

@@ -1,212 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}--- | Golden test management-module Test.Tasty.Silver.Manage-  (-  -- * Command line helpers-    defaultMain--  -- * The ingredient-  , acceptingTests-  , AcceptTests(..)--  -- * Programmatic API-  , acceptGoldenTests-  )-  where--import Test.Tasty hiding (defaultMain)-import Test.Tasty.Runners-import Test.Tasty.Options-import Test.Tasty.Silver.Internal-import Data.Typeable-import Data.Tagged-import Data.Proxy-import Data.Maybe-import Control.Monad.Cont-import Control.Monad.State-import Control.Exception-import Control.Concurrent.Async-import Text.Printf-import qualified Data.Text as T-import Data.Text.Encoding-import Options.Applicative-import System.Process.ByteString.Lazy as PL-import System.Process-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString as BS-import System.IO-import System.IO.Temp-import System.FilePath---- | Like @defaultMain@ from the main tasty package, but also includes the--- golden test management capabilities.-defaultMain :: TestTree -> IO ()-defaultMain = defaultMainWithIngredients [interactiveTests, acceptingTests, listingTests, consoleTestReporter]---- | This option, when set to 'True', specifies that we should run in the--- «accept tests» mode-newtype AcceptTests = AcceptTests Bool-  deriving (Eq, Ord, Typeable)-instance IsOption AcceptTests where-  defaultValue = AcceptTests False-  parseValue = fmap AcceptTests . safeRead-  optionName = return "accept"-  optionHelp = return "Accept current results of golden tests"-  optionCLParser =-    fmap AcceptTests $-    switch-      (  long (untag (optionName :: Tagged AcceptTests String))-      <> help (untag (optionHelp :: Tagged AcceptTests String))-      )--newtype Interactive = Interactive Bool-  deriving (Eq, Ord, Typeable)-instance IsOption Interactive where-  defaultValue = Interactive False-  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))-      )---acceptingTests :: Ingredient-acceptingTests = TestManager [Option (Proxy :: Proxy AcceptTests)] $-  \opts tree ->-    case lookupOption opts of-      AcceptTests False -> Nothing-      AcceptTests True -> Just $-        acceptGoldenTests opts tree--interactiveTests :: Ingredient-interactiveTests = TestManager [Option (Proxy :: Proxy Interactive)] $-  \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 }---- | «Accept» a golden test, i.e. reset the golden value to the currently--- produced value-acceptGoldenTest :: Golden -> IO ()-acceptGoldenTest (Golden _ getTested _  _ update) =-  vgRun $ liftIO . update =<< getTested---- | Accept all golden tests in the test tree-acceptGoldenTests :: OptionSet -> TestTree -> IO Bool-acceptGoldenTests opts tests = do-  let gs = getGoldenTests opts tests-  numExns <- flip execStateT (0 :: Int) $ forM_ gs $ \(n,g) -> do-    mbExn <- liftIO $ withAsync (acceptGoldenTest g) waitCatch-    case mbExn of-      Right {} -> liftIO $ printf "Accepted %s\n" n-      Left e -> do-        _ <- liftIO $ printf "Error when trying to accept %s: %s\n" n (show (e :: SomeException))-        ne <- get-        put $! ne+1--  -- warn when there were problems-  when (numExns > 0) $-    printf "NOTE: %d tests threw exceptions!\n" numExns-  -- is everything ok?-  return (numExns == 0)---- | Run in interactive mode (only tested on linux)-runTestsInteractive :: OptionSet -> TestTree -> IO Bool-runTestsInteractive opts tests = do-  let gs = getGoldenTests opts tests--  liftIO $ hSetBuffering stdout NoBuffering--  (nFail, nReject) <- flip execStateT (0, 0) $ forM_ gs runTest--  -- 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-    )--  -- 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"--            -- we can't run any update inside the vg monad,-            -- as the golden file might still be open-            (pFail, pReject, act) <- liftIO $ vgRun $ do-              tested <- getActual--              -- 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))--        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--showDiff :: TestName -> GDiff -> IO ()-showDiff n (DiffText tGold tAct) = do-  withSystemTempFile (n <.> "golden") (\fGold hGold -> do-    withSystemTempFile (n <.> "actual") (\fAct hAct -> do-      hSetBinaryMode hGold True-      hSetBinaryMode hAct True-      BS.hPut hGold (encodeUtf8 tGold)-      BS.hPut hAct (encodeUtf8 tAct)-      hClose hGold-      hClose hAct-      callProcess "sh"-        ["-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..."--showValue :: TestName -> GShow -> IO ()-showValue n (ShowText t) = showInLess n t--showInLess :: String -> T.Text -> IO ()-showInLess _ t = do-  -- TODO error handling...-  _ <- PL.readProcessWithExitCode "sh" ["-c", "less > /dev/tty"] inp-  return ()-  where inp = B.fromStrict $ encodeUtf8 t

@@ -1,5 +1,5 @@ name:                tasty-silver-version:             3.0.0.1+version:             3.0.1.0 synopsis:            Golden tests support for tasty. Fork of tasty-golden. description:   This package provides support for «golden testing».@@ -29,7 +29,7 @@     Haskell2010   exposed-modules:     Test.Tasty.Silver                        Test.Tasty.Silver.Advanced-                       Test.Tasty.Silver.Manage+                       Test.Tasty.Silver.Interactive   other-modules:                        Test.Tasty.Silver.Internal