Merge pull request #5204 from sellout/new-transcript-parser

unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md

@@ -1,6 +1,6 @@
 # Integration test: transcript
 
-```unison
+``` unison
 use .builtin
 
 unique type MyBool = MyTrue | MyFalse
@@ -27,7 +27,7 @@ main = do
     _ -> ()
 ```
 
-```ucm
+``` ucm
 
   Loading changes detected in scratch.u.
 
@@ -43,7 +43,7 @@ main = do
       resume : Request {g, Break} x -> x
 
 ```
-```ucm
+``` ucm
 .> add
 
   ⍟ I've added these definitions:

unison-cli/package.yaml

@@ -19,6 +19,7 @@ dependencies:
   - base
   - bytes
   - bytestring
+  - cmark
   - co-log-core
   - code-page
   - concurrent-output

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

@@ -18,6 +18,7 @@ module Unison.Codebase.TranscriptParser
   )
 where
 
+import CMark qualified
 import Control.Lens (use, (?~))
 import Crypto.Random qualified as Random
 import Data.Aeson qualified as Aeson
@@ -121,12 +122,14 @@ instance Show APIRequest where
   show (GetRequest txt) = "GET " <> Text.unpack txt
   show (APIComment txt) = "-- " <> Text.unpack 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
   = Ucm Hidden ExpectingError [UcmLine]
   | Unison Hidden ExpectingError (Maybe ScratchFileName) Text
   | API [APIRequest]
-  | UnprocessedFence FenceType Text
-  | Unfenced Text
+  | UnprocessedBlock CMark.Node
 
 instance Show UcmLine where
   show = \case
@@ -138,43 +141,34 @@ instance Show UcmLine where
         UcmContextProject projectAndBranch -> Text.unpack (into @Text projectAndBranch)
 
 instance Show Stanza where
-  show s = case s of
+  show s = (<> "\n") . Text.unpack . CMark.nodeToCommonmark [] Nothing $ stanzaToNode s
+
+stanzaToNode :: Stanza -> CMark.Node
+stanzaToNode =
+  \case
     Ucm _ _ cmds ->
-      unlines
-        [ "```ucm",
-          foldl (\x y -> x ++ show y) "" cmds,
-          "```"
-        ]
+      CMarkCodeBlock Nothing "ucm" . Text.pack $
+        foldl (\x y -> x ++ show y) "" cmds
     Unison _hide _ fname txt ->
-      unlines
-        [ "```unison",
-          case fname of
-            Nothing -> Text.unpack txt <> "```\n"
-            Just fname ->
-              unlines
-                [ "---",
-                  "title: " <> Text.unpack fname,
-                  "---",
-                  Text.unpack 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 ->
-      "```api\n"
-        <> ( apiRequests
-               & fmap show
-               & unlines
-           )
-        <> "```\n"
-    UnprocessedFence typ txt ->
-      unlines
-        [ "```" <> Text.unpack typ,
-          Text.unpack txt,
-          "```",
-          ""
-        ]
-    Unfenced txt -> Text.unpack txt
+      CMarkCodeBlock Nothing "api" . Text.pack $
+        ( apiRequests
+            & fmap show
+            & unlines
+        )
+    UnprocessedBlock node -> node
 
 parseFile :: FilePath -> IO (Either TranscriptError [Stanza])
 parseFile filePath = do
@@ -186,7 +180,7 @@ parseFile filePath = do
     else pure . Left . TranscriptParseError . Text.pack $ filePath <> " does not exist"
 
 parse :: String -> Text -> Either TranscriptError [Stanza]
-parse srcName txt = case P.parse (stanzas <* P.eof) srcName txt of
+parse srcName txt = case stanzas srcName txt of
   Right a -> Right a
   Left e -> Left . TranscriptParseError . Text.pack . P.errorBundlePretty $ e
 
@@ -337,7 +331,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
               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 (UnprocessedFence fenceDescription contents, Nothing)
+                Q.undequeue inputQueue (UnprocessedBlock $ CMarkCodeBlock Nothing fenceDescription contents, Nothing)
             awaitInput
           -- ucm command to run
           Just (Just ucmLine) -> do
@@ -420,10 +414,7 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
                       ++ "."
                   IO.hFlush IO.stdout
                 case s of
-                  Unfenced _ -> do
-                    liftIO (output $ show s)
-                    awaitInput
-                  UnprocessedFence _ _ -> do
+                  UnprocessedBlock _ -> do
                     liftIO (output $ show s)
                     awaitInput
                   Unison hide errOk filename txt -> do
@@ -432,22 +423,22 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
                     liftIO (writeIORef allowErrors errOk)
                     -- Open a ucm block which will contain the output from UCM
                     -- after processing the UnisonFileChanged event.
-                    liftIO (output "```ucm\n")
+                    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 (output "``` api\n")
                     liftIO (for_ apiRequests apiRequest)
-                    liftIO (output "```")
+                    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")
+                    liftIO (output "``` ucm")
                     traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
                     atomically . Q.enqueue cmdQueue $ Nothing
                     awaitInput
@@ -593,8 +584,12 @@ transcriptFailure out msg = do
 
 type P = P.Parsec Void Text
 
-stanzas :: P [Stanza]
-stanzas = P.many (fenced <|> unfenced)
+stanzas :: String -> Text -> Either (P.ParseErrorBundle Text Void) [Stanza]
+stanzas srcName = (\(CMark.Node _ _DOCUMENT blocks) -> traverse stanzaFromBlock blocks) . CMark.commonmarkToNode []
+  where
+    stanzaFromBlock block = case block of
+      CMarkCodeBlock _ info body -> fromMaybe (UnprocessedBlock block) <$> P.parse (fenced info) srcName body
+      _ -> pure $ UnprocessedBlock block
 
 ucmLine :: P UcmLine
 ucmLine = ucmCommand <|> ucmComment
@@ -636,18 +631,21 @@ apiRequest = do
       spaces
       pure (APIComment comment)
 
-fenced :: P Stanza
-fenced = do
-  fence
+-- | Produce the correct parser for the code block based on the provided info string.
+fenced :: Text -> P (Maybe Stanza)
+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
+        P.setInput body
         _ <- spaces
         cmds <- many ucmLine
-        pure $ Ucm hide err cmds
+        pure . pure $ Ucm hide err cmds
       "unison" ->
         do
           -- todo: this has to be more interesting
@@ -657,44 +655,17 @@ fenced = do
           hide <- lineToken hidden
           err <- lineToken expectingError
           fileName <- optional untilSpace1
-          blob <- spaces *> untilFence
-          pure $ Unison hide err fileName blob
+          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 $ API apiRequests
-      _ -> UnprocessedFence fenceType <$> untilFence
-  fence
+        pure . pure $ API apiRequests
+      _ -> pure Nothing
   pure stanza
 
--- Three backticks, consumes trailing spaces too
--- ```
-fence :: P ()
-fence = P.try $ do void (word "```"); spaces
-
--- Parses up until next fence
-unfenced :: P Stanza
-unfenced = Unfenced <$> untilFence
-
-untilFence :: P Text
-untilFence = do
-  _ <- P.lookAhead (P.takeP Nothing 1)
-  go mempty
-  where
-    go :: Seq Text -> P Text
-    go !acc = do
-      f <- P.lookAhead (P.optional fence)
-      case f of
-        Nothing -> do
-          oneOrTwoBackticks <- optional (word' "``" <|> word' "`")
-          let start = fromMaybe "" oneOrTwoBackticks
-          txt <- P.takeWhileP (Just "unfenced") (/= '`')
-          eof <- P.lookAhead (P.optional P.eof)
-          case eof of
-            Just _ -> pure $ fold (acc <> pure txt)
-            Nothing -> go (acc <> pure start <> pure txt)
-        Just _ -> pure $ fold acc
-
 word' :: Text -> P Text
 word' txt = P.try $ do
   chs <- P.takeP (Just $ show txt) (Text.length txt)

unison-cli/unison-cli.cabal

@@ -196,6 +196,7 @@ library
     , base
     , bytes
     , bytestring
+    , cmark
     , co-log-core
     , code-page
     , concurrent-output
@@ -337,6 +338,7 @@ executable transcripts
     , base
     , bytes
     , bytestring
+    , cmark
     , co-log-core
     , code-page
     , concurrent-output
@@ -485,6 +487,7 @@ test-suite cli-tests
     , base
     , bytes
     , bytestring
+    , cmark
     , co-log-core
     , code-page
     , concurrent-output

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
+``` ucm
 runtime-tests/selected> run tests
 
   ()

unison-src/builtin-tests/jit-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
+``` ucm
 runtime-tests/selected> run.native tests
 
   ()
@@ -17,7 +17,8 @@ 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.
-```unison
+
+``` unison
 foo = do
   go : Nat ->{Exception} ()
   go = cases
@@ -26,20 +27,20 @@ foo = do
   go 1000
 ```
 
-```ucm
+``` 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
+``` ucm
 scratch/main> run.native foo
 
   ()
@@ -53,14 +54,14 @@ 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
 runtime-tests/selected> run.native testBug
 
   💔💥
-  
+
   I've encountered a call to builtin.bug with the following
   value:
-  
+
     "testing"
 
 ```