Add regeneration for Golden files

There are a few things going on here that are slightly orthogonal, but are all uncontroversial progress that had to happen eventually: test runner options, logging, factoring out duplication in `TestResult`...

haskell/Main.hs

@@ -24,7 +24,7 @@ main = do
     -- terminalWidth <- Terminal.Size.width <<$>> Terminal.Size.size -- TODO this doesn't work in GHCID or GHCIWatch...
     terminalWidth <- pure $ Just 62
     T.putStrLn $ drawTree $ getTestTree tests
-    TL.putStrLn . displayTestResultsConsole terminalWidth =<< runTests () tests
+    TL.putStrLn . displayTestResultsConsole terminalWidth =<< runTests TestRunnerOpts{regenerateGoldenFiles = False} () tests
 
 tests :: TestTree IO ()
 tests =

haskell/Pre.hs

@@ -71,6 +71,7 @@ module Pre (
     TestName,
     getTestTree,
     displayTestResultsConsole,
+    TestRunnerOpts (..),
     runTests,
     assertEqual,
     assert,
@@ -99,8 +100,10 @@ import Control.Exception (SomeException, evaluate)
 import Control.Monad
 import Control.Monad.Catch (MonadCatch, MonadThrow, try)
 import Control.Monad.Except
-import Control.Monad.Loops
+import Control.Monad.Loops hiding (firstM)
+import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Writer
 import Data.Bifunctor
 import Data.Bool
 import Data.Char
@@ -128,7 +131,7 @@ import Data.Text.Lazy qualified as TL
 import Data.Time
 import Data.Traversable
 import Data.Tree hiding (drawTree)
-import Data.Tuple.Extra ((&&&))
+import Data.Tuple.Extra (firstM, (&&&))
 import Data.Void
 import Data.Word
 import GHC.Generics (Generic)
@@ -136,6 +139,8 @@ import GHC.TypeNats (KnownNat, Nat, type (+))
 import Linear (V2 (..))
 import Safe
 import System.Console.ANSI
+import System.Directory
+import System.FilePath
 import Text.Megaparsec hiding (Pos, State, Stream, many, some)
 import Text.Megaparsec.Char
 import Text.Megaparsec.Char.Lexer (decimal)
@@ -268,7 +273,16 @@ data TestCase m input output where
     TestCase :: (NFData output) => (input -> Test m output) -> TestCase m input output
     TestCaseLazy :: (input -> Test m output) -> TestCase m input output
 
-newtype Test m a = Test (ExceptT TestFailure m a)
+newtype Test m a
+    = Test
+        ( ExceptT
+            TestFailure
+            ( WriterT
+                [TestLogItem]
+                (ReaderT TestRunnerOpts m)
+            )
+            a
+        )
     deriving newtype
         ( Functor
         , Applicative
@@ -277,6 +291,8 @@ newtype Test m a = Test (ExceptT TestFailure m a)
         , MonadThrow
         , MonadCatch
         , MonadError TestFailure
+        , MonadWriter [TestLogItem]
+        , MonadReader TestRunnerOpts
         )
 
 -- | See `testLazy` for avoiding the `NFData` constraint.
@@ -289,14 +305,19 @@ It doesn't force the output before completion, which means that reported timings
 testLazy :: Text -> (input -> Test m output) -> [TestTree m output] -> TestTree m input
 testLazy n f = TestTree (TestName n) $ TestCaseLazy f
 
-data TestResult
+data TestResult = TestResult
-    = Pass TestName NominalDiffTime [TestResult]
+    { name :: TestName
-    | Fail TestName TestFailure
+    , logs :: [TestLogItem]
-    deriving (Show)
+    , result :: Either TestFailure (NominalDiffTime, [TestResult])
+    }
+
+data TestLogItem
+    = LogRegeneratedGolden
 
 data TestFailure
     = ExceptionFailure SomeException
     | AssertionFailure Text
+    | GoldenMissing
     | GoldenFailure {expected :: Text, actual :: Text}
 
 newtype TestName = TestName Text
@@ -310,18 +331,31 @@ displayTestResultsConsole terminalWidth testResult =
   where
     displayResult indent =
         (TL.replicate (fromIntegral indent) "  " <>) . \case
-            Pass (TestName name) dt children ->
+            TestResult{name = TestName name, logs, result} ->
-                TL.fromStrict (header Green '✓' name indent (Just dt))
+                case result of
-                    <> TL.concat (map (displayResult (indent + 1)) children)
+                    Right (dt, children) ->
-            Fail (TestName name) e ->
+                        TL.fromStrict (header Green '✓' name indent (Just dt) <> displayLogs)
-                TL.fromStrict $
+                            <> TL.concat (map (displayResult (indent + 1)) children)
-                    header Red '✗' name indent Nothing
+                    Left e ->
-                        <> setColour Vivid Red
+                        TL.fromStrict $
-                        <> paddedAllLines (T.replicate (indent * 2) " ") case e of
+                            header Red '✗' name indent Nothing
-                            ExceptionFailure ex -> T.show ex
+                                <> displayLogs
-                            AssertionFailure t -> T.stripEnd t
+                                <> setColour Vivid Red
-                            GoldenFailure{expected, actual} ->
+                                <> indentAllLines indent case e of
-                                "Expected:\n" <> T.stripEnd expected <> "\nActual:\n" <> T.stripEnd actual
+                                    ExceptionFailure ex -> T.show ex
+                                    AssertionFailure t -> T.stripEnd t
+                                    GoldenMissing -> "Golden file missing"
+                                    GoldenFailure{expected, actual} ->
+                                        "Expected:\n" <> T.stripEnd expected <> "\nActual:\n" <> T.stripEnd actual
+              where
+                displayLogs =
+                    setColour Dull Magenta
+                        <> indentAllLines
+                            indent
+                            ( flip foldMap logs \case
+                                LogRegeneratedGolden -> "Created golden file"
+                            )
+                        <> setColour Dull Magenta
     header colour icon name indent time =
         setColour Vivid colour
             <> T.singleton icon
@@ -345,6 +379,7 @@ displayTestResultsConsole terminalWidth testResult =
                 time
             <> "\n"
     paddedAllLines p = T.unlines . map (p <>) . T.lines
+    indentAllLines indent = paddedAllLines $ T.replicate (indent * 2) " "
     showTime (nominalDiffTimeToSeconds -> MkFixed duration) =
         -- SI prefixes, and always exactly 2 decimal places, or 3 if there's no prefix
         T.show res
@@ -373,16 +408,21 @@ displayTestResultsConsole terminalWidth testResult =
     sgr = T.pack . setSGRCode
     setColour d c = sgr [SetColor Foreground d c]
 
-runTests :: (MonadIO m, MonadCatch m) => a -> TestTree m a -> m TestResult
+data TestRunnerOpts = TestRunnerOpts
-runTests r0 (TestTree name tc ts) =
+    { regenerateGoldenFiles :: Bool
+    }
+
+runTests :: (MonadIO m, MonadCatch m) => TestRunnerOpts -> a -> TestTree m a -> m TestResult
+runTests opts r0 (TestTree name tc ts) =
     let Test t = Control.Monad.Catch.try $ runTest tc
-     in runExceptT t >>= \case
+     in runReaderT (runWriterT (runExceptT t)) opts
-            Left e ->
+            >>= fmap (\(result, logs) -> TestResult{name, logs, result}) . firstM \case
-                pure $ Fail name e
+                Left e ->
-            Right (Left e) ->
+                    pure $ Left e
-                pure $ Fail name $ ExceptionFailure e
+                Right (Left e) ->
-            Right (Right (r, dt)) ->
+                    pure $ Left $ ExceptionFailure e
-                Pass name dt <$> for ts (runTests r)
+                Right (Right (r, dt)) ->
+                    Right . (dt,) <$> for ts (runTests opts r)
   where
     runTest = \case
         TestCase f -> timed (liftIO . evaluate . DeepSeq.force) $ f r0
@@ -401,6 +441,21 @@ assert s b = if b then pure () else assertFailure s
 assertFailure :: (Monad m) => Text -> Test m a
 assertFailure = throwError . AssertionFailure
 golden :: (MonadIO m, MonadFail m) => FilePath -> Text -> Test m ()
-golden p actual = do
+golden file actual = do
-    expected <- liftIO $ T.readFile p
+    TestRunnerOpts{..} <- ask
-    if expected == actual then pure () else throwError $ GoldenFailure{expected, actual}
+    exists <- liftIO $ doesFileExist file
+    if exists
+        then do
+            expected <- liftIO $ T.readFile file
+            if expected == actual then pure () else throwError $ GoldenFailure{expected, actual}
+        else do
+            if regenerateGoldenFiles
+                then
+                    let parents = dropWhile null $ scanl (</>) "" $ splitDirectories $ takeDirectory file
+                     in tell [LogRegeneratedGolden] >> liftIO do
+                            for_ parents \dir -> do
+                                parentExists <- liftIO $ doesDirectoryExist dir
+                                when (not parentExists) $ createDirectory dir
+                            T.writeFile file actual
+                else
+                    throwError GoldenMissing