Add support for “known failures” to transcripts

unison-cli/src/Unison/Codebase/Transcript.hs

@@ -3,6 +3,7 @@
 -- | The data model for Unison transcripts.
 module Unison.Codebase.Transcript
   ( ExpectingError,
+    HasBug,
     ScratchFileName,
     Hidden (..),
     UcmLine (..),
@@ -25,6 +26,8 @@ import Unison.Project (ProjectAndBranch)
 
 type ExpectingError = Bool
 
+type HasBug = Bool
+
 type ScratchFileName = Text
 
 data Hidden = Shown | HideOutput | HideAll
@@ -56,13 +59,14 @@ type Stanza = Either CMark.Node ProcessedBlock
 data InfoTags a = InfoTags
   { hidden :: Hidden,
     expectingError :: ExpectingError,
+    hasBug :: HasBug,
     generated :: Bool,
     additionalTags :: a
   }
   deriving (Eq, Ord, Read, Show)
 
 defaultInfoTags :: a -> InfoTags a
-defaultInfoTags = InfoTags Shown False False
+defaultInfoTags = InfoTags Shown False False False
 
 -- | If the `additionalTags` form a `Monoid`, then you don’t need to provide a default value for them.
 defaultInfoTags' :: (Monoid a) => InfoTags a

unison-cli/src/Unison/Codebase/Transcript/Parser.hs

@@ -23,7 +23,7 @@ import Data.Char qualified as Char
 import Data.Text qualified as Text
 import Text.Megaparsec qualified as P
 import Text.Megaparsec.Char qualified as P
-import Unison.Codebase.Transcript hiding (expectingError, generated, hidden)
+import Unison.Codebase.Transcript hiding (expectingError, generated, hasBug, hidden)
 import Unison.Prelude
 import Unison.Project (fullyQualifiedProjectAndBranchNamesParser)
 
@@ -50,9 +50,9 @@ formatStanzas =
 
 processedBlockToNode :: ProcessedBlock -> CMark.Node
 processedBlockToNode = \case
-  Ucm tags cmds -> mkNode (\() -> "") "ucm" tags $ foldr ((<>) . formatUcmLine) "" cmds
-  Unison tags txt -> mkNode (maybe "" (" " <>)) "unison" tags txt
-  API tags apiRequests -> mkNode (\() -> "") "api" tags $ foldr ((<>) . formatAPIRequest) "" apiRequests
+  Ucm tags cmds -> mkNode (\() -> Nothing) "ucm" tags $ foldr ((<>) . formatUcmLine) "" cmds
+  Unison tags txt -> mkNode id "unison" tags txt
+  API tags apiRequests -> mkNode (\() -> Nothing) "api" tags $ foldr ((<>) . formatAPIRequest) "" apiRequests
   where
     mkNode formatA lang = CMarkCodeBlock Nothing . formatInfoString formatA lang
 
@@ -98,20 +98,28 @@ apiRequest =
     <|> APIComment <$> (P.chunk "--" *> restOfLine)
     <|> APIResponseLine <$> (P.chunk "  " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n")
 
-formatInfoString :: (a -> Text) -> Text -> InfoTags a -> Text
+formatInfoString :: (a -> Maybe Text) -> Text -> InfoTags a -> Text
 formatInfoString formatA language infoTags =
   let infoTagText = formatInfoTags formatA infoTags
    in if Text.null infoTagText then language else language <> " " <> infoTagText
 
-formatInfoTags :: (a -> Text) -> InfoTags a -> Text
-formatInfoTags formatA (InfoTags hidden expectingError generated additionalTags) =
-  formatHidden hidden <> formatExpectingError expectingError <> formatGenerated generated <> formatA additionalTags
+formatInfoTags :: (a -> Maybe Text) -> InfoTags a -> Text
+formatInfoTags formatA (InfoTags hidden expectingError hasBug generated additionalTags) =
+  Text.intercalate " " $
+    catMaybes
+      [ formatHidden hidden,
+        formatExpectingError expectingError,
+        formatHasBug hasBug,
+        formatGenerated generated,
+        formatA additionalTags
+      ]
 
 infoTags :: P a -> P (InfoTags a)
 infoTags p =
   InfoTags
     <$> lineToken hidden
     <*> lineToken expectingError
+    <*> lineToken hasBug
     <*> lineToken generated
     <*> p
     <* P.single '\n'
@@ -135,26 +143,32 @@ lineToken p = p <* nonNewlineSpaces
 nonNewlineSpaces :: P ()
 nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')
 
-formatHidden :: Hidden -> Text
+formatHidden :: Hidden -> Maybe Text
 formatHidden = \case
-  HideAll -> ":hide:all"
-  HideOutput -> ":hide"
-  Shown -> ""
+  HideAll -> pure ":hide-all"
+  HideOutput -> pure ":hide"
+  Shown -> Nothing
 
 hidden :: P Hidden
 hidden =
-  (HideAll <$ word ":hide:all")
+  (HideAll <$ word ":hide-all")
     <|> (HideOutput <$ word ":hide")
     <|> pure Shown
 
-formatExpectingError :: ExpectingError -> Text
-formatExpectingError = bool "" ":error"
+formatExpectingError :: ExpectingError -> Maybe Text
+formatExpectingError = bool Nothing $ pure ":error"
 
 expectingError :: P ExpectingError
 expectingError = isJust <$> optional (word ":error")
 
-formatGenerated :: ExpectingError -> Text
-formatGenerated = bool "" ":added-by-ucm"
+formatHasBug :: HasBug -> Maybe Text
+formatHasBug = bool Nothing $ pure ":bug"
+
+hasBug :: P HasBug
+hasBug = isJust <$> optional (word ":bug")
+
+formatGenerated :: ExpectingError -> Maybe Text
+formatGenerated = bool Nothing $ pure ":added-by-ucm"
 
 generated :: P Bool
 generated = isJust <$> optional (word ":added-by-ucm")

unison-cli/src/Unison/Codebase/Transcript/Runner.hs

@@ -171,6 +171,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
   currentTags <- newIORef Nothing
   isHidden <- newIORef Shown
   allowErrors <- newIORef False
+  expectFailure <- newIORef False
   hasErrors <- newIORef False
   mBlock <- newIORef Nothing
   let patternMap = Map.fromList $ (\p -> (patternName p, p) : ((,p) <$> aliases p)) =<< validInputs
@@ -204,12 +205,25 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
           -- We shorten the terminal width, because "Transcript" manages a 2-space indent for output lines.
           Pretty.toPlain (terminalWidth - 2) line
 
-      maybeDieWithMsg :: String -> IO ()
+      maybeDieWithMsg :: Pretty.Pretty Pretty.ColorText -> IO ()
       maybeDieWithMsg msg = do
-        errOk <- readIORef allowErrors
-        if errOk
-          then writeIORef hasErrors True
-          else dieWithMsg msg
+        liftIO $ writeIORef hasErrors True
+        liftIO (liftA2 (,) (readIORef allowErrors) (readIORef expectFailure)) >>= \case
+          (False, False) -> liftIO . dieWithMsg $ Pretty.toPlain terminalWidth msg
+          (True, True) -> do
+            appendFailingStanza
+            fixedBug out $
+              Text.unlines
+                [ "The stanza above marked with `:error :bug` is now failing with",
+                  "",
+                  "```",
+                  Text.pack $ Pretty.toPlain terminalWidth msg,
+                  "```",
+                  "",
+                  "so you can remove `:bug` and close any appropriate Github issues. If the error message is different \
+                  \from the expected error message, open a new issue and reference it in this transcript."
+                ]
+          (_, _) -> pure ()
 
       apiRequest :: APIRequest -> IO [APIRequest]
       apiRequest req = do
@@ -220,9 +234,13 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
           APIComment {} -> pure $ pure req
           GetRequest path ->
             either
-              (([] <$) . maybeDieWithMsg . show)
+              (([] <$) . maybeDieWithMsg . Pretty.string . show)
               ( either
-                  (([] <$) . maybeDieWithMsg . (("Error decoding response from " <> Text.unpack path <> ": ") <>))
+                  ( ([] <$)
+                      . maybeDieWithMsg
+                      . (("Error decoding response from " <> Pretty.text path <> ": ") <>)
+                      . Pretty.string
+                  )
                   ( \(v :: Aeson.Value) ->
                       pure $
                         if hide
@@ -309,12 +327,9 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
                       >>= either
                         -- invalid command is treated as a failure
                         ( \msg -> do
-                            liftIO $ writeIORef hasErrors True
-                            liftIO (readIORef allowErrors) >>= \case
-                              True -> do
-                                liftIO $ outputUcmResult msg
-                                Cli.returnEarlyWithoutOutput
-                              False -> liftIO . dieWithMsg $ Pretty.toPlain terminalWidth msg
+                            liftIO $ outputUcmResult msg
+                            liftIO $ maybeDieWithMsg msg
+                            Cli.returnEarlyWithoutOutput
                         )
                         -- No input received from this line, try again.
                         (maybe Cli.returnEarlyWithoutOutput $ pure . Right . snd)
@@ -325,6 +340,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
             writeIORef isHidden $ hidden infoTags
             outputEcho $ pure block
             writeIORef allowErrors $ expectingError infoTags
+            writeIORef expectFailure $ hasBug infoTags
           -- Open a ucm block which will contain the output from UCM after processing the `UnisonFileChanged` event.
           -- Close the ucm block after processing the UnisonFileChanged event.
           atomically . Q.enqueue cmdQueue $ Nothing
@@ -335,13 +351,15 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
           liftIO do
             writeIORef isHidden $ hidden infoTags
             writeIORef allowErrors $ expectingError infoTags
+            writeIORef expectFailure $ hasBug infoTags
             outputEcho . pure . API infoTags . fold =<< traverse apiRequest apiRequests
           Cli.returnEarlyWithoutOutput
         Ucm infoTags cmds -> do
           liftIO do
             writeIORef currentTags $ pure infoTags
             writeIORef isHidden $ hidden infoTags
             writeIORef allowErrors $ expectingError infoTags
+            writeIORef expectFailure $ hasBug infoTags
             writeIORef hasErrors False
           traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
           atomically . Q.enqueue cmdQueue $ Nothing
@@ -382,6 +400,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
         liftIO $ writeIORef currentTags Nothing
         liftIO $ writeIORef isHidden Shown
         liftIO $ writeIORef allowErrors False
+        liftIO $ writeIORef expectFailure False
         maybe (liftIO finishTranscript) (uncurry processStanza) =<< atomically (Q.tryDequeue inputQueue)
 
       awaitInput :: Cli (Either Event Input)
@@ -409,22 +428,14 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
       print :: Output.Output -> IO ()
       print o = do
         msg <- notifyUser dir o
-        errOk <- readIORef allowErrors
         outputUcmResult msg
-        when (Output.isFailure o) $
-          if errOk
-            then writeIORef hasErrors True
-            else dieWithMsg $ Pretty.toPlain terminalWidth msg
+        when (Output.isFailure o) $ maybeDieWithMsg msg
 
       printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs
       printNumbered o = do
         let (msg, numberedArgs) = notifyNumbered o
-        errOk <- readIORef allowErrors
         outputUcmResult msg
-        when (Output.isNumberedFailure o) $
-          if errOk
-            then writeIORef hasErrors True
-            else dieWithMsg $ Pretty.toPlain terminalWidth msg
+        when (Output.isNumberedFailure o) $ maybeDieWithMsg msg
         pure numberedArgs
 
       -- Looks at the current stanza and decides if it is contained in the
@@ -447,13 +458,21 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL
       dieUnexpectedSuccess :: IO ()
       dieUnexpectedSuccess = do
         errOk <- readIORef allowErrors
+        expectBug <- readIORef expectFailure
         hasErr <- readIORef hasErrors
-        when (errOk && not hasErr) $ do
-          appendFailingStanza
-          transcriptFailure
-            out
-            "The transcript was expecting an error in the stanza above, but did not encounter one."
-            Nothing
+        case (errOk, expectBug, hasErr) of
+          (True, False, False) -> do
+            appendFailingStanza
+            transcriptFailure
+              out
+              "The transcript was expecting an error in the stanza above, but did not encounter one."
+              Nothing
+          (False, True, False) -> do
+            fixedBug
+              out
+              "The stanza above with `:bug` is now passing! You can remove `:bug` and close any appropriate Github \
+              \issues."
+          (_, _, _) -> pure ()
 
   authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion
 
@@ -508,6 +527,22 @@ transcriptFailure out heading mbody = do
               <> foldr ((:) . CMarkCodeBlock Nothing "") [] mbody
         )
 
+fixedBug :: IORef (Seq Stanza) -> Text -> IO b
+fixedBug out body = do
+  texts <- readIORef out
+  -- `CMark.commonmarkToNode` returns a @DOCUMENT@, which won’t be rendered inside another document, so we strip the
+  -- outer `CMark.Node`.
+  let CMark.Node _ _DOCUMENT bodyNodes = CMark.commonmarkToNode [CMark.optNormalize] body
+  UnliftIO.throwIO . RunFailure $
+    texts
+      <> Seq.fromList
+        ( Left
+            <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🎉") []],
+                  CMark.Node Nothing (CMark.HEADING 2) [CMark.Node Nothing (CMark.TEXT "You fixed a bug!") []]
+                ]
+              <> bodyNodes
+        )
+
 data Error
   = ParseError (P.ParseErrorBundle Text Void)
   | RunFailure (Seq Stanza)

unison-src/builtin-tests/interpreter-tests.output.md

@@ -4,7 +4,7 @@ If you want to add or update tests, you can create a branch of that project, and
 
 Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release.
 
-``` ucm :hide:error
+``` ucm :hide :error
 scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line.
 
 scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm.

unison-src/builtin-tests/jit-tests.output.md

@@ -4,6 +4,18 @@ If you want to add or update tests, you can create a branch of that project, and
 
 Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release.
 
+``` ucm :hide :error
+scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line.
+
+scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm.
+
+scratch/main> delete.project runtime-tests
+```
+
+``` ucm :hide
+scratch/main> clone @unison/runtime-tests/releases/0.0.1 runtime-tests/selected
+```
+
 ``` ucm
 runtime-tests/selected> run.native tests
 
@@ -12,8 +24,8 @@ runtime-tests/selected> run.native tests
 runtime-tests/selected> run.native tests.jit.only
 
   ()
-
 ```
+
 Per Dan:
 It's testing a flaw in how we were sending code from a scratch file to the native runtime, when that happened multiple times.
 Related to the verifiable refs and recursive functions.
@@ -27,19 +39,18 @@ foo = do
   go 1000
 ```
 
-``` ucm
-
+``` ucm :added-by-ucm
   Loading changes detected in scratch.u.
 
   I found and typechecked these definitions in scratch.u. If you
   do an `add` or `update`, here's how your codebase would
   change:
-  
+
     ⍟ These new definitions are ok to `add`:
 
       foo : '{Exception} ()
-
 ```
+
 ``` ucm
 scratch/main> run.native foo
 
@@ -48,20 +59,19 @@ scratch/main> run.native foo
 scratch/main> run.native foo
 
   ()
-
 ```
+
 This can also only be tested by separately running this test, because
 it is exercising the protocol that ucm uses to talk to the jit during
 an exception.
 
-``` ucm
+``` ucm :error
 runtime-tests/selected> run.native testBug
 
   💔💥
-  
+
   I've encountered a call to builtin.bug with the following
   value:
-
-    "testing"
 
+    "testing"
 ```