From 00f6c8c95458b459981a52c0775283fb17566b7f Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Thu, 11 Jul 2024 16:55:56 -0600 Subject: [PATCH 1/2] Refactoring TranscriptParser MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- .../src/Unison/Codebase/TranscriptParser.hs | 304 +++++++----------- unison-cli/src/Unison/Main.hs | 93 +++--- unison-cli/tests/Unison/Test/Ucm.hs | 23 +- unison-cli/transcripts/Transcripts.hs | 11 +- .../transcripts/error-messages.output.md | 6 +- .../generic-parse-errors.output.md | 6 +- 6 files changed, 194 insertions(+), 249 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index ab433d96fc..c413ff56e7 100644 --- 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) - -instance Show Stanza where - show s = (<> "\n") . Text.unpack . CMark.nodeToCommonmark [] Nothing $ stanzaToNode s - -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 - -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" - -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 - -type TranscriptRunner = - ( String -> - Text -> - (FilePath, Codebase IO Symbol Ann) -> - IO (Either TranscriptError Text) - ) -withTranscriptRunner :: +formatUcmLine :: UcmLine -> Text +formatUcmLine = \case + UcmCommand context txt -> formatContext context <> "> " <> txt + UcmComment txt -> "--" <> txt + where + formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch + +formatStanza :: Stanza -> Text +formatStanza = either formatNode formatProcessedBlock + +formatNode :: CMark.Node -> Text +formatNode = (<> "\n") . CMark.nodeToCommonmark [] Nothing + +formatProcessedBlock :: ProcessedBlock -> Text +formatProcessedBlock = formatNode . processedBlockToNode + +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 + +parse :: FilePath -> Text -> Either Error [Stanza] +parse srcName = first ParseError . stanzas srcName + +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) diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index ca74688fd6..1459a516a8 100644 --- 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 - ] - ) - 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." - ] + 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) - 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 -> diff --git a/unison-cli/tests/Unison/Test/Ucm.hs b/unison-cli/tests/Unison/Test/Ucm.hs index 7fdca8710b..c5e4f3c960 100644 --- 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 diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 5810df590f..8dcdf806dd 100644 --- 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 diff --git a/unison-src/transcripts/error-messages.output.md b/unison-src/transcripts/error-messages.output.md index ed5d4c1784..0b3e334aa6 100644 --- 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: diff --git a/unison-src/transcripts/generic-parse-errors.output.md b/unison-src/transcripts/generic-parse-errors.output.md index 6c5c5048b1..081548ea11 100644 --- 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: From b1cf12330ad293c4e8907597edf808d3fd1bbee1 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Mon, 15 Jul 2024 19:32:45 -0600 Subject: [PATCH 2/2] Split `TranscriptParser` into three modules MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - `Transcript` – the data model - `Transcript.Parser` – the parser and printer - `Transcript.Runner` – the runner There is unfortunately still some printing tightly coupled to the runner, but this makes it more obvious. Also, the runner is the only component tied to the CLI. --- unison-cli/src/Unison/Codebase/Transcript.hs | 50 +++++ .../src/Unison/Codebase/Transcript/Parser.hs | 166 ++++++++++++++ .../Runner.hs} | 204 ++---------------- unison-cli/src/Unison/Main.hs | 2 +- unison-cli/tests/Unison/Test/Ucm.hs | 2 +- unison-cli/transcripts/Transcripts.hs | 2 +- unison-cli/unison-cli.cabal | 4 +- 7 files changed, 238 insertions(+), 192 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Transcript.hs create mode 100644 unison-cli/src/Unison/Codebase/Transcript/Parser.hs rename unison-cli/src/Unison/Codebase/{TranscriptParser.hs => Transcript/Runner.hs} (75%) diff --git a/unison-cli/src/Unison/Codebase/Transcript.hs b/unison-cli/src/Unison/Codebase/Transcript.hs new file mode 100644 index 0000000000..bd5bbd058f --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Transcript.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | The data model for Unison transcripts. +module Unison.Codebase.Transcript + ( ExpectingError, + ScratchFileName, + Hidden (..), + UcmLine (..), + UcmContext (..), + APIRequest (..), + pattern CMarkCodeBlock, + Stanza, + ProcessedBlock (..), + ) +where + +import CMark qualified +import Unison.Core.Project (ProjectBranchName, ProjectName) +import Unison.Prelude +import Unison.Project (ProjectAndBranch) + +type ExpectingError = Bool + +type ScratchFileName = Text + +data Hidden = Shown | HideOutput | HideAll + deriving (Eq, Show) + +data UcmLine + = UcmCommand UcmContext Text + | -- | Text does not include the '--' prefix. + UcmComment Text + +-- | Where a command is run: a project branch (myproject/mybranch>). +data UcmContext + = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) + +data APIRequest + = GetRequest Text + | APIComment Text + +pattern CMarkCodeBlock :: (Maybe CMark.PosInfo) -> Text -> Text -> CMark.Node +pattern CMarkCodeBlock pos info body = CMark.Node pos (CMark.CODE_BLOCK info body) [] + +type Stanza = Either CMark.Node ProcessedBlock + +data ProcessedBlock + = Ucm Hidden ExpectingError [UcmLine] + | Unison Hidden ExpectingError (Maybe ScratchFileName) Text + | API [APIRequest] diff --git a/unison-cli/src/Unison/Codebase/Transcript/Parser.hs b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs new file mode 100644 index 0000000000..8bbd8be622 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs @@ -0,0 +1,166 @@ +-- | Parse and print CommonMark (like Github-flavored Markdown) transcripts. +module Unison.Codebase.Transcript.Parser + ( -- * printing + formatAPIRequest, + formatUcmLine, + formatStanza, + formatNode, + formatProcessedBlock, + + -- * conversion + processedBlockToNode, + + -- * parsing + stanzas, + ucmLine, + apiRequest, + fenced, + hidden, + expectingError, + language, + ) +where + +import CMark qualified +import Data.Char qualified as Char +import Data.Text qualified as Text +import Data.These (These (..)) +import Text.Megaparsec qualified as P +import Unison.Codebase.Transcript +import Unison.Prelude +import Unison.Project (ProjectAndBranch (ProjectAndBranch)) + +formatAPIRequest :: APIRequest -> Text +formatAPIRequest = \case + GetRequest txt -> "GET " <> txt + APIComment txt -> "-- " <> txt + +formatUcmLine :: UcmLine -> Text +formatUcmLine = \case + UcmCommand context txt -> formatContext context <> "> " <> txt + UcmComment txt -> "--" <> txt + where + formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch + +formatStanza :: Stanza -> Text +formatStanza = either formatNode formatProcessedBlock + +formatNode :: CMark.Node -> Text +formatNode = (<> "\n") . CMark.nodeToCommonmark [] Nothing + +formatProcessedBlock :: ProcessedBlock -> Text +formatProcessedBlock = formatNode . processedBlockToNode + +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 P = P.Parsec Void Text + +stanzas :: FilePath -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza] +stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromNode blocks) . CMark.commonmarkToNode [] + where + 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 + where + ucmCommand :: P UcmLine + ucmCommand = do + context <- + P.try do + contextString <- P.takeWhile1P Nothing (/= '>') + context <- + case (tryFrom @Text contextString) of + (Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch)) + _ -> fail "expected project/branch or absolute path" + void $ lineToken $ word ">" + pure context + line <- P.takeWhileP Nothing (/= '\n') <* spaces + pure $ UcmCommand context line + + ucmComment :: P UcmLine + ucmComment = do + word "--" + line <- P.takeWhileP Nothing (/= '\n') <* spaces + pure $ UcmComment line + +apiRequest :: P APIRequest +apiRequest = do + apiComment <|> getRequest + where + getRequest = do + word "GET" + spaces + path <- P.takeWhile1P Nothing (/= '\n') + spaces + pure (GetRequest path) + apiComment = do + word "--" + comment <- P.takeWhileP Nothing (/= '\n') + spaces + pure (APIComment comment) + +-- | Produce the correct parser for the code block based on the provided info string. +fenced :: Text -> P (Maybe ProcessedBlock) +fenced info = do + body <- P.getInput + P.setInput info + fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language) + 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 + 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 + chs <- P.takeP (Just $ show txt) (Text.length txt) + guard (chs == txt) + pure txt + +lineToken :: P a -> P a +lineToken p = p <* nonNewlineSpaces + +nonNewlineSpaces :: P () +nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t') + +hidden :: P Hidden +hidden = + (HideAll <$ word ":hide:all") + <|> (HideOutput <$ word ":hide") + <|> pure Shown + +expectingError :: P ExpectingError +expectingError = isJust <$> optional (word ":error") + +untilSpace1 :: P Text +untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace) + +language :: P Text +language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_') + +spaces :: P () +spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs similarity index 75% rename from unison-cli/src/Unison/Codebase/TranscriptParser.hs rename to unison-cli/src/Unison/Codebase/Transcript/Runner.hs index c413ff56e7..6e084a2eba 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs @@ -1,23 +1,18 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} --- | Parse and execute CommonMark (like Github-flavored Markdown) transcripts. -module Unison.Codebase.TranscriptParser +-- | Execute transcripts. +module Unison.Codebase.Transcript.Runner ( Error (..), Runner, withRunner, ) where -import CMark qualified import Control.Lens (use, (?~)) import Crypto.Random qualified as Random import Data.Aeson qualified as Aeson import Data.Aeson.Encode.Pretty qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BL -import Data.Char qualified as Char import Data.Configurator qualified as Configurator import Data.Configurator.Types (Config) import Data.IORef @@ -51,6 +46,8 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Runtime qualified as Runtime +import Unison.Codebase.Transcript +import Unison.Codebase.Transcript.Parser qualified as Transcript import Unison.Codebase.Verbosity (Verbosity, isSilent) import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine @@ -58,7 +55,6 @@ import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) import Unison.CommandLine.InputPatterns (validInputs) import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser) import Unison.CommandLine.Welcome (asciiartUnison) -import Unison.Core.Project (ProjectBranchName, ProjectName (..)) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal @@ -86,66 +82,6 @@ terminalWidth = 65 accessTokenEnvVarKey :: String accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN" -type ExpectingError = Bool - -type ScratchFileName = Text - -data Hidden = Shown | HideOutput | HideAll - deriving (Eq, Show) - -data UcmLine - = UcmCommand UcmContext Text - | UcmComment Text -- Text does not include the '--' prefix. - --- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>). -data UcmContext - = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName) - -data APIRequest - = GetRequest Text - | APIComment Text - -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) [] - -type Stanza = Either CMark.Node ProcessedBlock - -data ProcessedBlock - = Ucm Hidden ExpectingError [UcmLine] - | Unison Hidden ExpectingError (Maybe ScratchFileName) Text - | API [APIRequest] - -formatUcmLine :: UcmLine -> Text -formatUcmLine = \case - UcmCommand context txt -> formatContext context <> "> " <> txt - UcmComment txt -> "--" <> txt - where - formatContext (UcmContextProject projectAndBranch) = into @Text projectAndBranch - -formatStanza :: Stanza -> Text -formatStanza = either formatNode formatProcessedBlock - -formatNode :: CMark.Node -> Text -formatNode = (<> "\n") . CMark.nodeToCommonmark [] Nothing - -formatProcessedBlock :: ProcessedBlock -> Text -formatProcessedBlock = formatNode . processedBlockToNode - -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 - -parse :: FilePath -> Text -> Either Error [Stanza] -parse srcName = first ParseError . stanzas srcName - type Runner = String -> Text -> @@ -155,7 +91,8 @@ type Runner = 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 -} -> + -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic + Bool -> Verbosity -> UCMVersion -> FilePath -> @@ -166,10 +103,10 @@ 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 + let parsed = Transcript.stanzas transcriptName transcriptSrc result <- for parsed \stanzas -> do liftIO $ run isTest verbosity codebaseDir stanzas codebase runtime sbRuntime nRuntime config ucmVersion (tShow baseUrl) - pure $ join @(Either Error) result + pure . join $ first ParseError result where withRuntimes :: FilePath -> (Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a @@ -193,7 +130,8 @@ withRunner isTest verbosity ucmVersion nrtp configFile action = do (\(config, _cancelConfig) -> action (Just config)) run :: - Bool {- Whether to treat this transcript run as a transcript test, which will try to make output deterministic -} -> + -- | Whether to treat this transcript run as a transcript test, which will try to make output deterministic + Bool -> Verbosity -> FilePath -> [Stanza] -> @@ -265,7 +203,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV apiRequest :: APIRequest -> IO () apiRequest req = do - output . Text.unpack $ formatAPIRequest req <> "\n" + output . Text.unpack $ Transcript.formatAPIRequest req <> "\n" case req of APIComment {} -> pure () GetRequest path -> do @@ -299,7 +237,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV Just (Just ucmLine) -> do case ucmLine of p@(UcmComment {}) -> do - liftIO . output . Text.unpack $ "\n" <> formatUcmLine p + liftIO . output . Text.unpack $ "\n" <> Transcript.formatUcmLine p awaitInput p@(UcmCommand context lineTxt) -> do curPath <- Cli.getCurrentProjectPath @@ -337,7 +275,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV case words . Text.unpack $ lineTxt of [] -> awaitInput args -> do - liftIO . output . Text.unpack $ "\n" <> formatUcmLine p <> "\n" + liftIO . output . Text.unpack $ "\n" <> Transcript.formatUcmLine p <> "\n" numberedArgs <- use #numberedArgs PP.ProjectAndBranch projId branchId <- PP.toProjectAndBranch . NonEmpty.head <$> use #projectPathStack let getProjectRoot = liftIO $ Codebase.expectProjectBranchRoot codebase projId branchId @@ -375,13 +313,13 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV IO.hFlush IO.stdout either ( \node -> do - liftIO . output . Text.unpack $ formatNode node + liftIO . output . Text.unpack $ Transcript.formatNode node awaitInput ) ( \block -> case block of Unison hide errOk filename txt -> do liftIO (writeIORef hidden hide) - liftIO . outputEcho . Text.unpack $ formatProcessedBlock block + liftIO . outputEcho . Text.unpack $ Transcript.formatProcessedBlock block liftIO (writeIORef allowErrors errOk) -- Open a ucm block which will contain the output from UCM -- after processing the UnisonFileChanged event. @@ -462,7 +400,7 @@ run isTest verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmV appendFailingStanza = do stanzaOpt <- readIORef mStanza currentOut <- readIORef out - let stnz = maybe "" (Text.unpack . formatStanza . fst) stanzaOpt + let stnz = maybe "" (Text.unpack . Transcript.formatStanza . fst) stanzaOpt unless (stnz `isSubsequenceOf` concat currentOut) $ modifyIORef' out (\acc -> acc <> pure stnz) @@ -532,116 +470,6 @@ transcriptFailure out msg = do texts <- readIORef out UnliftIO.throwIO . RunFailure $ mconcat (Text.pack <$> toList texts) <> "\n\n\128721\n\n" <> msg <> "\n" -type P = P.Parsec Void Text - -stanzas :: FilePath -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza] -stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromNode blocks) . CMark.commonmarkToNode [] - where - 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 - where - ucmCommand :: P UcmLine - ucmCommand = do - context <- - P.try do - contextString <- P.takeWhile1P Nothing (/= '>') - context <- - case (tryFrom @Text contextString) of - (Right (These project branch)) -> pure (UcmContextProject (ProjectAndBranch project branch)) - _ -> fail "expected project/branch or absolute path" - void $ lineToken $ word ">" - pure context - line <- P.takeWhileP Nothing (/= '\n') <* spaces - pure $ UcmCommand context line - - ucmComment :: P UcmLine - ucmComment = do - word "--" - line <- P.takeWhileP Nothing (/= '\n') <* spaces - pure $ UcmComment line - -apiRequest :: P APIRequest -apiRequest = do - apiComment <|> getRequest - where - getRequest = do - word "GET" - spaces - path <- P.takeWhile1P Nothing (/= '\n') - spaces - pure (GetRequest path) - apiComment = do - word "--" - comment <- P.takeWhileP Nothing (/= '\n') - spaces - pure (APIComment comment) - --- | Produce the correct parser for the code block based on the provided info string. -fenced :: Text -> P (Maybe ProcessedBlock) -fenced info = do - body <- P.getInput - P.setInput info - fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language) - 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 - 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 - chs <- P.takeP (Just $ show txt) (Text.length txt) - guard (chs == txt) - pure txt - -word :: Text -> P Text -word = word' - -lineToken :: P a -> P a -lineToken p = p <* nonNewlineSpaces - -nonNewlineSpaces :: P () -nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t') - -hidden :: P Hidden -hidden = - (HideAll <$ word ":hide:all") - <|> (HideOutput <$ word ":hide") - <|> pure Shown - -expectingError :: P ExpectingError -expectingError = isJust <$> optional (word ":error") - -untilSpace1 :: P Text -untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace) - -language :: P Text -language = P.takeWhileP Nothing (\ch -> Char.isDigit ch || Char.isLower ch || ch == '_') - -spaces :: P () -spaces = void $ P.takeWhileP (Just "spaces") Char.isSpace - data Error = ParseError (P.ParseErrorBundle Text Void) | RunFailure Text diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 1459a516a8..990f11354f 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -74,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 Transcript +import Unison.Codebase.Transcript.Runner qualified as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine (watchConfig) import Unison.CommandLine.Helpers (plural') diff --git a/unison-cli/tests/Unison/Test/Ucm.hs b/unison-cli/tests/Unison/Test/Ucm.hs index c5e4f3c960..1a8033c52b 100644 --- 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 Transcript +import Unison.Codebase.Transcript.Runner qualified as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Parser.Ann (Ann) import Unison.Prelude (traceM) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 8dcdf806dd..77220a3061 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -25,7 +25,7 @@ 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 as Transcript +import Unison.Codebase.Transcript.Runner as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Prelude import UnliftIO.STM qualified as STM diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index b5a29cc483..77030bfdf6 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -106,7 +106,9 @@ library Unison.Codebase.Editor.StructuredArgument Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser - Unison.Codebase.TranscriptParser + Unison.Codebase.Transcript + Unison.Codebase.Transcript.Parser + Unison.Codebase.Transcript.Runner Unison.Codebase.Watch Unison.CommandLine Unison.CommandLine.BranchRelativePath