Refactoring TranscriptParser

A bunch of small changes in TranscriptParser - remove dead code - don’t use `Show` for formatted output - put processed blocks in a separate sum type from unprocessed blocks - remove `Transcript` from identifiers (changed importers to use `qualified as Transcript`) - deduplicated some error reporting And one happy fix, IMO – got rid of the `Text.init` that plagued me in
2024-09-11 02:25:39 +03:00 · 2024-07-11 16:55:56 -06:00 · 2024-07-11 16:55:56 -06:00 · 00f6c8c954
commit 00f6c8c954
parent 525e923467
6 changed files with 188 additions and 243 deletions
--- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs
+++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs
@ -3,18 +3,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}

-{- Parse and execute markdown transcripts.
-}
+-- | Parse and execute CommonMark (like Github-flavored Markdown) transcripts.
 module Unison.Codebase.TranscriptParser
-  ( Stanza (..),
-    FenceType,
-    ExpectingError,
-    Hidden,
-    TranscriptError (..),
-    UcmLine (..),
-    withTranscriptRunner,
-    parse,
-    parseFile,
+  ( Error (..),
+    Runner,
+    withRunner,
  )
 where

@ -35,7 +28,6 @@ import Data.Text qualified as Text
 import Data.These (These (..))
 import Data.UUID.V4 qualified as UUID
 import Network.HTTP.Client qualified as HTTP
-import System.Directory (doesFileExist)
 import System.Environment (lookupEnv)
 import System.Exit (die)
 import System.IO qualified as IO
@ -98,8 +90,6 @@ type ExpectingError = Bool

 type ScratchFileName = Text

-type FenceType = Text
-
 data Hidden = Shown | HideOutput | HideAll
  deriving (Eq, Show)

@ -115,78 +105,54 @@ data APIRequest
  = GetRequest Text
  | APIComment Text

-instance Show APIRequest where
-  show (GetRequest txt) = "GET " <> Text.unpack txt
-  show (APIComment txt) = "-- " <> Text.unpack txt
+formatAPIRequest :: APIRequest -> Text
+formatAPIRequest = \case
+  GetRequest txt -> "GET " <> txt
+  APIComment txt -> "-- " <> txt

 pattern CMarkCodeBlock :: (Maybe CMark.PosInfo) -> Text -> Text -> CMark.Node
 pattern CMarkCodeBlock pos info body = CMark.Node pos (CMark.CODE_BLOCK info body) []

-data Stanza
+type Stanza = Either CMark.Node ProcessedBlock
+
+data ProcessedBlock
  = Ucm Hidden ExpectingError [UcmLine]
  | Unison Hidden ExpectingError (Maybe ScratchFileName) Text
  | API [APIRequest]
-  | UnprocessedBlock CMark.Node

-instance Show UcmLine where
-  show = \case
-    UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
-    UcmComment txt -> "--" ++ Text.unpack txt
-    where
-      showContext (UcmContextProject projectAndBranch) = Text.unpack (into @Text projectAndBranch)
+formatUcmLine :: UcmLine -> Text
+formatUcmLine = \case
+  UcmCommand context txt -> formatContext context <> "> " <> txt
+  UcmComment txt -> "--" <> txt
+  where
+    formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch

-instance Show Stanza where
-  show s = (<> "\n") . Text.unpack . CMark.nodeToCommonmark [] Nothing $ stanzaToNode s
+formatStanza :: Stanza -> Text
+formatStanza = either formatNode formatProcessedBlock

-stanzaToNode :: Stanza -> CMark.Node
-stanzaToNode =
-  \case
-    Ucm _ _ cmds ->
-      CMarkCodeBlock Nothing "ucm" . Text.pack $
-        foldl (\x y -> x ++ show y) "" cmds
-    Unison _hide _ fname txt ->
-      CMarkCodeBlock Nothing "unison" . Text.pack $
-        unlines
-          [ case fname of
-              Nothing -> Text.unpack txt
-              Just fname ->
-                unlines
-                  [ "---",
-                    "title: " <> Text.unpack fname,
-                    "---",
-                    Text.unpack txt
-                  ]
-          ]
-    API apiRequests ->
-      CMarkCodeBlock Nothing "api" . Text.pack $
-        ( apiRequests
-            & fmap show
-            & unlines
-        )
-    UnprocessedBlock node -> node
+formatNode :: CMark.Node -> Text
+formatNode = (<> "\n") . CMark.nodeToCommonmark [] Nothing

-parseFile :: FilePath -> IO (Either TranscriptError [Stanza])
-parseFile filePath = do
-  exists <- doesFileExist filePath
-  if exists
-    then do
-      txt <- readUtf8 filePath
-      pure $ parse filePath txt
-    else pure . Left . TranscriptParseError . Text.pack $ filePath <> " does not exist"
+formatProcessedBlock :: ProcessedBlock -> Text
+formatProcessedBlock = formatNode . processedBlockToNode

-parse :: String -> Text -> Either TranscriptError [Stanza]
-parse srcName txt = case stanzas srcName txt of
-  Right a -> Right a
-  Left e -> Left . TranscriptParseError . Text.pack . P.errorBundlePretty $ e
+processedBlockToNode :: ProcessedBlock -> CMark.Node
+processedBlockToNode = \case
+  Ucm _ _ cmds -> CMarkCodeBlock Nothing "ucm" $ foldr ((<>) . formatUcmLine) "" cmds
+  Unison _hide _ fname txt ->
+    CMarkCodeBlock Nothing "unison" $ maybe txt (\fname -> Text.unlines ["---", "title: " <> fname, "---", txt]) fname
+  API apiRequests -> CMarkCodeBlock Nothing "api" $ Text.unlines $ formatAPIRequest <$> apiRequests

-type TranscriptRunner =
-  ( String ->
-    Text ->
-    (FilePath, Codebase IO Symbol Ann) ->
-    IO (Either TranscriptError Text)
-  )
+parse :: FilePath -> Text -> Either Error [Stanza]
+parse srcName = first ParseError . stanzas srcName

-withTranscriptRunner ::
+type Runner =
+  String ->
+  Text ->
+  (FilePath, Codebase IO Symbol Ann) ->
+  IO (Either Error Text)
+
+withRunner ::
  forall m r.
  (UnliftIO.MonadUnliftIO m) =>
  Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} ->
@ -194,16 +160,16 @@ withTranscriptRunner ::
  UCMVersion ->
  FilePath ->
  Maybe FilePath ->
-  (TranscriptRunner -> m r) ->
+  (Runner -> m r) ->
  m r
-withTranscriptRunner isTest verbosity ucmVersion nrtp configFile action = do
+withRunner isTest verbosity ucmVersion nrtp configFile action = do
  withRuntimes nrtp \runtime sbRuntime nRuntime -> withConfig \config -> do
    action \transcriptName transcriptSrc (codebaseDir, codebase) -> do
      Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase \baseUrl -> do
        let parsed = parse transcriptName transcriptSrc
        result <- for parsed \stanzas -> do
          liftIO $ run isTest verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl)
-        pure $ join @(Either TranscriptError) result
+        pure $ join @(Either Error) result
  where
    withRuntimes ::
      FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a
@ -238,7 +204,7 @@ run ::
  Maybe Config ->
  UCMVersion ->
  Text ->
-  IO (Either TranscriptError Text)
+  IO (Either Error Text)
 run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion baseURL = UnliftIO.try do
  httpManager <- HTTP.newManager HTTP.defaultManagerSettings
  (initialPP, emptyCausalHashId) <- Codebase.runTransaction codebase do
@ -299,7 +265,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV

      apiRequest :: APIRequest -> IO ()
      apiRequest req = do
-        output (show req <> "\n")
+        output . Text.unpack $ formatAPIRequest req <> "\n"
        case req of
          APIComment {} -> pure ()
          GetRequest path -> do
@ -327,13 +293,13 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
              for (reverse scratchFileUpdates) \(fp, contents) -> do
                let fenceDescription = "unison:added-by-ucm " <> fp
                -- Output blocks for any scratch file updates the ucm block triggered.
-                Q.undequeue inputQueue (UnprocessedBlock $ CMarkCodeBlock Nothing fenceDescription contents, Nothing)
+                Q.undequeue inputQueue (Left $ CMarkCodeBlock Nothing fenceDescription contents, Nothing)
            awaitInput
          -- ucm command to run
          Just (Just ucmLine) -> do
            case ucmLine of
              p@(UcmComment {}) -> do
-                liftIO (output ("\n" <> show p))
+                liftIO . output . Text.unpack $ "\n" <> formatUcmLine p
                awaitInput
              p@(UcmCommand context lineTxt) -> do
                curPath <- Cli.getCurrentProjectPath
@ -371,7 +337,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
                    case words . Text.unpack $ lineTxt of
                      [] -> awaitInput
                      args -> do
-                        liftIO (output ("\n" <> show p <> "\n"))
+                        liftIO . output . Text.unpack $ "\n" <> formatUcmLine p <> "\n"
                        numberedArgs <- use #numberedArgs
                        PP.ProjectAndBranch projId branchId <- PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack
                        let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId
@ -407,35 +373,39 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
                      ++ show (length stanzas)
                      ++ "."
                  IO.hFlush IO.stdout
-                case s of
-                  UnprocessedBlock _ -> do
-                    liftIO (output $ show s)
-                    awaitInput
-                  Unison hide errOk filename txt -> do
-                    liftIO (writeIORef hidden hide)
-                    liftIO (outputEcho $ show s)
-                    liftIO (writeIORef allowErrors errOk)
-                    -- Open a ucm block which will contain the output from UCM
-                    -- after processing the UnisonFileChanged event.
-                    liftIO (output "``` ucm\n")
-                    -- Close the ucm block after processing the UnisonFileChanged event.
-                    atomically . Q.enqueue cmdQueue $ Nothing
-                    let sourceName = fromMaybe "scratch.u" filename
-                    liftIO $ updateVirtualFile sourceName txt
-                    pure $ Left (UnisonFileChanged sourceName txt)
-                  API apiRequests -> do
-                    liftIO (output "``` api\n")
-                    liftIO (for_ apiRequests apiRequest)
-                    liftIO (output "```\n\n")
-                    awaitInput
-                  Ucm hide errOk cmds -> do
-                    liftIO (writeIORef hidden hide)
-                    liftIO (writeIORef allowErrors errOk)
-                    liftIO (writeIORef hasErrors False)
-                    liftIO (output "``` ucm")
-                    traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
-                    atomically . Q.enqueue cmdQueue $ Nothing
-                    awaitInput
+                either
+                  ( \node -> do
+                      liftIO . output . Text.unpack $ formatNode node
+                      awaitInput
+                  )
+                  ( \block -> case block of
+                      Unison hide errOk filename txt -> do
+                        liftIO (writeIORef hidden hide)
+                        liftIO . outputEcho . Text.unpack $ formatProcessedBlock block
+                        liftIO (writeIORef allowErrors errOk)
+                        -- Open a ucm block which will contain the output from UCM
+                        -- after processing the UnisonFileChanged event.
+                        liftIO (output "``` ucm\n")
+                        -- Close the ucm block after processing the UnisonFileChanged event.
+                        atomically . Q.enqueue cmdQueue $ Nothing
+                        let sourceName = fromMaybe "scratch.u" filename
+                        liftIO $ updateVirtualFile sourceName txt
+                        pure $ Left (UnisonFileChanged sourceName txt)
+                      API apiRequests -> do
+                        liftIO (output "``` api\n")
+                        liftIO (for_ apiRequests apiRequest)
+                        liftIO (output "```\n\n")
+                        awaitInput
+                      Ucm hide errOk cmds -> do
+                        liftIO (writeIORef hidden hide)
+                        liftIO (writeIORef allowErrors errOk)
+                        liftIO (writeIORef hasErrors False)
+                        liftIO (output "``` ucm")
+                        traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
+                        atomically . Q.enqueue cmdQueue $ Nothing
+                        awaitInput
+                  )
+                  s

      loadPreviousUnisonBlock name = do
        ufs <- readIORef unisonFiles
@ -492,7 +462,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
      appendFailingStanza = do
        stanzaOpt <- readIORef mStanza
        currentOut <- readIORef out
-        let stnz = maybe "" show (fmap fst stanzaOpt :: Maybe Stanza)
+        let stnz = maybe "" (Text.unpack . formatStanza . fst) stanzaOpt
        unless (stnz `isSubsequenceOf` concat currentOut) $
          modifyIORef' out (\acc -> acc <> pure stnz)

@ -502,13 +472,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
        output "\n```\n\n"
        appendFailingStanza
        transcriptFailure out $
-          Text.unlines
-            [ "\128721",
-              "",
-              "The transcript failed due to an error in the stanza above. The error is:",
-              "",
-              Text.pack msg
-            ]
+          "The transcript failed due to an error in the stanza above. The error is:\n\n" <> Text.pack msg

      dieUnexpectedSuccess :: IO ()
      dieUnexpectedSuccess = do
@ -517,12 +481,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
        when (errOk && not hasErr) $ do
          output "\n```\n\n"
          appendFailingStanza
-          transcriptFailure out $
-            Text.unlines
-              [ "\128721",
-                "",
-                "The transcript was expecting an error in the stanza above, but did not encounter one."
-              ]
+          transcriptFailure out "The transcript was expecting an error in the stanza above, but did not encounter one."

  authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion

@ -571,20 +530,17 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV
 transcriptFailure :: IORef (Seq String) -> Text -> IO b
 transcriptFailure out msg = do
  texts <- readIORef out
-  UnliftIO.throwIO
-    . TranscriptRunFailure
-    $ Text.concat (Text.pack <$> toList texts)
-      <> "\n\n"
-      <> msg
+  UnliftIO.throwIO . RunFailure $ mconcat (Text.pack <$> toList texts) <> "\n\n\128721\n\n" <> msg <> "\n"

 type P = P.Parsec Void Text

-stanzas :: String -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza]
-stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromBlock blocks) . CMark.commonmarkToNode []
+stanzas :: FilePath -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza]
+stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromNode blocks) . CMark.commonmarkToNode []
  where
-    stanzaFromBlock block = case block of
-      CMarkCodeBlock _ info body -> fromMaybe (UnprocessedBlock block) <$> P.parse (fenced info) srcName body
-      _ -> pure $ UnprocessedBlock block
+    stanzaFromNode :: CMark.Node -> Either (P.ParseErrorBundle Text Void) Stanza
+    stanzaFromNode node = case node of
+      CMarkCodeBlock _ info body -> maybe (Left node) pure <$> P.parse (fenced info) srcName body
+      _ -> pure $ Left node

 ucmLine :: P UcmLine
 ucmLine = ucmCommand <|> ucmComment
@ -626,39 +582,32 @@ apiRequest = do
      pure (APIComment comment)

 -- | Produce the correct parser for the code block based on the provided info string.
-fenced :: Text -> P (Maybe Stanza)
+fenced :: Text -> P (Maybe ProcessedBlock)
 fenced info = do
  body <- P.getInput
  P.setInput info
  fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language)
-  stanza <-
-    case fenceType of
-      "ucm" -> do
-        hide <- hidden
-        err <- expectingError
+  case fenceType of
+    "ucm" -> do
+      hide <- hidden
+      err <- expectingError
+      P.setInput body
+      pure . Ucm hide err <$> (spaces *> many ucmLine)
+    "unison" ->
+      do
+        -- todo: this has to be more interesting
+        -- ```unison:hide
+        -- ```unison
+        -- ```unison:hide:all scratch.u
+        hide <- lineToken hidden
+        err <- lineToken expectingError
+        fileName <- optional untilSpace1
        P.setInput body
-        _ <- spaces
-        cmds <- many ucmLine
-        pure . pure $ Ucm hide err cmds
-      "unison" ->
-        do
-          -- todo: this has to be more interesting
-          -- ```unison:hide
-          -- ```unison
-          -- ```unison:hide:all scratch.u
-          hide <- lineToken hidden
-          err <- lineToken expectingError
-          fileName <- optional untilSpace1
-          P.setInput body
-          blob <- spaces *> (Text.init <$> P.getInput)
-          pure . pure $ Unison hide err fileName blob
-      "api" -> do
-        P.setInput body
-        _ <- spaces
-        apiRequests <- many apiRequest
-        pure . pure $ API apiRequests
-      _ -> pure Nothing
-  pure stanza
+        pure . Unison hide err fileName <$> (spaces *> P.getInput)
+    "api" -> do
+      P.setInput body
+      pure . API <$> (spaces *> many apiRequest)
+    _ -> pure Nothing

 word' :: Text -> P Text
 word' txt = P.try $ do
@ -669,9 +618,6 @@ word' txt = P.try $ do
 word :: Text -> P Text
 word = word'

-- token :: P a -> P a
-- token p = p <* spaces
-
 lineToken :: P a -> P a
 lineToken p = p <* nonNewlineSpaces

@ -679,11 +625,10 @@ nonNewlineSpaces :: P ()
 nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')

 hidden :: P Hidden
-hidden = (\case Just x -> x; Nothing -> Shown) <$> optional go
-  where
-    go =
-      ((\_ -> HideAll) <$> (word ":hide:all"))
-        <|> ((\_ -> HideOutput) <$> (word ":hide"))
+hidden =
+  (HideAll <$ word ":hide:all")
+    <|> (HideOutput <$ word ":hide")
+    <|> pure Shown

 expectingError :: P ExpectingError
 expectingError = isJust <$> optional (word ":error")
@ -697,11 +642,8 @@ language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch
 spaces :: P ()
 spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace

-- single :: Char -> P Char
-- single t = P.satisfy (== t)
-
-data TranscriptError
-  = TranscriptRunFailure Text
-  | TranscriptParseError Text
+data Error
+  = ParseError (P.ParseErrorBundle Text Void)
+  | RunFailure Text
  deriving stock (Show)
  deriving anyclass (Exception)
--- a/unison-cli/src/Unison/Main.hs
+++ b/unison-cli/src/Unison/Main.hs
@ -60,6 +60,7 @@ import System.IO.CodePage (withCP65001)
 import System.IO.Error (catchIOError)
 import System.IO.Temp qualified as Temp
 import System.Path qualified as Path
+import Text.Megaparsec qualified as MP
 import U.Codebase.Sqlite.Queries qualified as Queries
 import Unison.Cli.ProjectUtils qualified as ProjectUtils
 import Unison.Codebase (Codebase, CodebasePath)
@ -73,7 +74,7 @@ import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.ProjectPath qualified as PP
 import Unison.Codebase.Runtime qualified as Rt
 import Unison.Codebase.SqliteCodebase qualified as SC
-import Unison.Codebase.TranscriptParser qualified as TR
+import Unison.Codebase.TranscriptParser qualified as Transcript
 import Unison.Codebase.Verbosity qualified as Verbosity
 import Unison.CommandLine (watchConfig)
 import Unison.CommandLine.Helpers (plural')
@ -424,49 +425,55 @@ runTranscripts' version progName mcodepath nativeRtp transcriptDir markdownFiles
  currentDir <- getCurrentDirectory
  configFilePath <- getConfigFilePath mcodepath
  -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously.
-  and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) (SC.MigrateAutomatically SC.Backup SC.Vacuum) \(_, codebasePath, theCodebase) -> do
-    let isTest = False
-    TR.withTranscriptRunner isTest Verbosity.Verbose (Version.gitDescribeWithDate version) nativeRtp (Just configFilePath) $ \runTranscript -> do
-      for markdownFiles $ \(MarkdownFile fileName) -> do
-        transcriptSrc <- readUtf8 fileName
-        result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
-        let outputFile = replaceExtension (currentDir </> fileName) ".output.md"
-        (output, succeeded) <- case result of
-          Left err -> case err of
-            TR.TranscriptParseError err -> do
-              PT.putPrettyLn $
-                P.callout
-                  "❓"
-                  ( P.lines
-                      [ P.indentN 2 "An error occurred while parsing the following file: " <> P.string fileName,
-                        "",
-                        P.indentN 2 $ P.text err
-                      ]
+  and
+    <$> getCodebaseOrExit
+      (Just (DontCreateCodebaseWhenMissing transcriptDir))
+      (SC.MigrateAutomatically SC.Backup SC.Vacuum)
+      \(_, codebasePath, theCodebase) -> do
+        let isTest = False
+        Transcript.withRunner
+          isTest
+          Verbosity.Verbose
+          (Version.gitDescribeWithDate version)
+          nativeRtp
+          (Just configFilePath)
+          \runTranscript -> do
+            for markdownFiles $ \(MarkdownFile fileName) -> do
+              transcriptSrc <- readUtf8 fileName
+              result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase)
+              let outputFile = replaceExtension (currentDir </> fileName) ".output.md"
+              output <-
+                either
+                  ( uncurry ($>) . first (PT.putPrettyLn . P.callout "❓" . P.lines) . \case
+                      Transcript.ParseError err ->
+                        let msg = MP.errorBundlePretty err
+                         in ( [ P.indentN 2 $
+                                  "An error occurred while parsing the following file: " <> P.string fileName,
+                                "",
+                                P.indentN 2 $ P.string msg
+                              ],
+                              Text.pack msg
+                            )
+                      Transcript.RunFailure msg ->
+                        ( [ P.indentN 2 $ "An error occurred while running the following file: " <> P.string fileName,
+                            "",
+                            P.indentN 2 (P.text msg),
+                            P.string $
+                              "Run `"
+                                <> progName
+                                <> " --codebase "
+                                <> codebasePath
+                                <> "` "
+                                <> "to do more work with it."
+                          ],
+                          msg
+                        )
                  )
-              pure (err, False)
-            TR.TranscriptRunFailure err -> do
-              PT.putPrettyLn $
-                P.callout
-                  "❓"
-                  ( P.lines
-                      [ P.indentN 2 "An error occurred while running the following file: " <> P.string fileName,
-                        "",
-                        P.indentN 2 $ P.text err,
-                        P.text $
-                          "Run `"
-                            <> Text.pack progName
-                            <> " --codebase "
-                            <> Text.pack codebasePath
-                            <> "` "
-                            <> "to do more work with it."
-                      ]
-                  )
-              pure (err, False)
-          Right mdOut -> do
-            pure (mdOut, True)
-        writeUtf8 outputFile output
-        putStrLn $ "💾  Wrote " <> outputFile
-        pure succeeded
+                  pure
+                  result
+              writeUtf8 outputFile output
+              putStrLn $ "💾  Wrote " <> outputFile
+              pure $ isRight result

 runTranscripts ::
  Version ->
--- a/unison-cli/tests/Unison/Test/Ucm.hs
+++ b/unison-cli/tests/Unison/Test/Ucm.hs
@ -24,7 +24,7 @@ import Unison.Codebase qualified as Codebase
 import Unison.Codebase.Init qualified as Codebase.Init
 import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError (..))
 import Unison.Codebase.SqliteCodebase qualified as SC
-import Unison.Codebase.TranscriptParser qualified as TR
+import Unison.Codebase.TranscriptParser qualified as Transcript
 import Unison.Codebase.Verbosity qualified as Verbosity
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude (traceM)
@ -66,17 +66,16 @@ runTranscript :: Codebase -> Transcript -> IO TranscriptOutput
 runTranscript (Codebase codebasePath fmt) transcript = do
  let err e = fail $ "Parse error: \n" <> show e
      cbInit = case fmt of CodebaseFormat2 -> SC.init
-  let isTest = True
-  TR.withTranscriptRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $ \runner -> do
-    result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do
-      Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
-      let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript
-      output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
-      when debugTranscriptOutput $ traceM output
-      pure output
-    case result of
-      Left e -> fail $ P.toANSI 80 (P.shown e)
-      Right x -> pure x
+      isTest = True
+  Transcript.withRunner isTest Verbosity.Silent "Unison.Test.Ucm.runTranscript Invalid Version String" rtp configFile $
+    \runner -> do
+      result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DoLock SC.DontMigrate \codebase -> do
+        Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
+        let transcriptSrc = stripMargin . Text.pack $ unTranscript transcript
+        output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
+        when debugTranscriptOutput $ traceM output
+        pure output
+      either (fail . P.toANSI 80 . P.shown) pure result
  where
    configFile = Nothing
    -- Note: this needs to be properly configured if these tests ever
--- a/unison-cli/transcripts/Transcripts.hs
+++ b/unison-cli/transcripts/Transcripts.hs
@ -22,9 +22,10 @@ import System.FilePath
  )
 import System.IO.CodePage (withCP65001)
 import System.IO.Silently (silence)
+import Text.Megaparsec qualified as MP
 import Unison.Codebase.Init (withTemporaryUcmCodebase)
 import Unison.Codebase.SqliteCodebase qualified as SC
-import Unison.Codebase.TranscriptParser (TranscriptError (..), withTranscriptRunner)
+import Unison.Codebase.TranscriptParser as Transcript
 import Unison.Codebase.Verbosity qualified as Verbosity
 import Unison.Prelude
 import UnliftIO.STM qualified as STM
@ -48,7 +49,7 @@ testBuilder ::
 testBuilder expectFailure recordFailure runtimePath dir prelude transcript = scope transcript $ do
  outputs <- io . withTemporaryUcmCodebase SC.init Verbosity.Silent "transcript" SC.DoLock $ \(codebasePath, codebase) -> do
    let isTest = True
-    withTranscriptRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
+    Transcript.withRunner isTest Verbosity.Silent "TODO: pass version here" runtimePath Nothing \runTranscript -> do
      for files \filePath -> do
        transcriptSrc <- readUtf8 filePath
        out <- silence $ runTranscript filePath transcriptSrc (codebasePath, codebase)
@ -57,12 +58,12 @@ testBuilder expectFailure recordFailure runtimePath dir prelude transcript = sco
    (filePath, Left err) -> do
      let outputFile = outputFileForTranscript filePath
      case err of
-        TranscriptParseError msg -> do
+        Transcript.ParseError errors -> do
          when (not expectFailure) $ do
-            let errMsg = "Error parsing " <> filePath <> ": " <> Text.unpack msg
+            let errMsg = "Error parsing " <> filePath <> ": " <> MP.errorBundlePretty errors
            io $ recordFailure (filePath, Text.pack errMsg)
            crash errMsg
-        TranscriptRunFailure errOutput -> do
+        Transcript.RunFailure errOutput -> do
          io $ writeUtf8 outputFile errOutput
          when (not expectFailure) $ do
            io $ Text.putStrLn errOutput
--- a/unison-src/transcripts/error-messages.output.md
+++ b/unison-src/transcripts/error-messages.output.md
@ -211,8 +211,7 @@ foo = match 1 with

  I got confused here:
  
-      2 |   2 -- no right-hand-side
-  
+      3 | 
  
  I was surprised to find an end of section here.
  I was expecting one of these instead:
@ -258,8 +257,7 @@ x = match Some a with

  I got confused here:
  
-      6 |         2
-  
+      7 | 
  
  I was surprised to find an end of section here.
  I was expecting one of these instead:
--- a/unison-src/transcripts/generic-parse-errors.output.md
+++ b/unison-src/transcripts/generic-parse-errors.output.md
@ -96,8 +96,7 @@ x = "hi

  I got confused here:
  
-      1 | x = "hi
-  
+      2 | 
  
  I was surprised to find an end of input here.
  I was expecting one of these instead:
@ -117,8 +116,7 @@ y : a

  I got confused here:
  
-      1 | y : a 
-  
+      2 | 
  
  I was surprised to find an end of section here.
  I was expecting one of these instead: