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")
     <|> (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,23 @@ 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) ->
+            transcriptFailure
+              out
+              ( Text.pack . Pretty.toPlain terminalWidth $
+                  "The stanza above previously had an incorrect successful result, but now fails with"
+                    <> "\n"
+                    <> Pretty.border 2 msg
+                    <> "\n"
+                    <> "if this is the expected result, remove `:bug`, otherwise remove `:error`."
+              )
+              Nothing
+          (_, _) -> pure ()
 
       apiRequest :: APIRequest -> IO [APIRequest]
       apiRequest req = do
@@ -220,9 +232,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 +325,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 +338,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 +349,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 +398,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 +426,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 +456,19 @@ 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
+            appendFailingStanza
+            transcriptFailure out "The stanza above is now passing! Please remove `:bug` from it." Nothing
+          (_, _, _) -> pure ()
 
   authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion
 

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"
 ```

unison-src/transcripts-using-base/fix5178.md

@@ -0,0 +1,20 @@
+``` unison
+foo = {{
+@source{Stream.emit}
+}}
+```
+
+``` ucm
+scratch/main> add
+```
+
+Viewing `foo` via `scratch/main> ui` shows the correct source, but `display foo` gives us an error message (but not an error – this is incorrectly considered a successful result)
+
+I think there are two separate issues here:
+
+1. this message should be considered an error, not success; and
+2. this should actually work like `ui` and give us the source of the ability member, not complain about there being no such term in the codebase.
+
+``` ucm :error :bug
+scratch/main> display foo
+```