Merge pull request #5406 from sellout/transcript-edit

Make transcripts idempotent
unisonweb · Nov 26, 2024 · d17b1f6 · d17b1f6
2 parents 612756d + 7e26050
commit d17b1f6
Show file tree

Hide file tree

Showing 633 changed files with 18,576 additions and 25,392 deletions.
diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md
@@ -8,33 +8,18 @@ assignees: ''
 ---
 
 **Describe and demonstrate the bug**
-Please attach a [ucm transcript](https://www.unison-lang.org/docs/tooling/transcripts/) if possible, calling out the unexpected behavior in the text. e.g.
+This should be written as a [ucm transcript](https://www.unison-lang.org/docs/tooling/transcripts/) if possible, calling out the unexpected behavior in the text. e.g.
 
-Input:
-```` markdown
 ``` unison :hide
 a = 1
 ```
-Here I typo the next command and `ucm` silently does nothing. I would have expected an error message:
-``` ucm
-.> add b
-```
-````
-
-Output:
-```` markdown
-``` unison
-a = 1
-```
 
 Here I typo the next command and `ucm` silently does nothing, I would have expected an error message:
-``` ucm
-.> add b
-
 
+``` ucm
+scratch/main> add b
 
 ```
-````
 
 **Screenshots**
 If applicable, add screenshots to help explain your problem.

diff --git a/nix/haskell-nix-flake.nix b/nix/haskell-nix-flake.nix
@@ -32,6 +32,7 @@
         (args.nativeBuildInputs or [])
         ++ [
           pkgs.cachix
+          pkgs.gettext # for envsubst, used by unison-src/builtin-tests/interpreter-tests.sh
           pkgs.hpack
           pkgs.pkg-config
           pkgs.stack-wrapped

diff --git a/parser-typechecker/src/Unison/Util/TQueue.hs b/parser-typechecker/src/Unison/Util/TQueue.hs
@@ -8,8 +8,11 @@ import UnliftIO.STM hiding (TQueue)
 
 data TQueue a = TQueue (TVar (Seq a)) (TVar Word64)
 
+prepopulatedIO :: forall a m. (MonadIO m) => Seq a -> m (TQueue a)
+prepopulatedIO as = TQueue <$> newTVarIO as <*> newTVarIO (fromIntegral $ length as)
+
 newIO :: forall a m. (MonadIO m) => m (TQueue a)
-newIO = TQueue <$> newTVarIO mempty <*> newTVarIO 0
+newIO = prepopulatedIO mempty
 
 size :: TQueue a -> STM Int
 size (TQueue q _) = S.length <$> readTVar q

diff --git a/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md b/unison-cli-integration/integration-tests/IntegrationTests/transcript.output.md
@@ -1,5 +1,13 @@
 # Integration test: transcript
 
+``` ucm :hide
+scratch/main> builtins.mergeio lib.builtins
+
+scratch/main> load ./unison-src/transcripts-using-base/base.u
+
+scratch/main> add
+```
+
 ``` unison
 use lib.builtins
 
@@ -27,32 +35,30 @@ main = do
     _ -> ()
 ```
 
-``` 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`:
     
       structural ability Break
       type MyBool
       main   : '{IO, Exception} ()
       resume : Request {g, Break} x -> x
-
 ```
+
 ``` ucm
 scratch/main> add
 
   ⍟ I've added these definitions:
-  
+
     structural ability Break
     type MyBool
     main   : '{IO, Exception} ()
     resume : Request {g, Break} x -> x
 
 scratch/main> compile main ./unison-cli-integration/integration-tests/IntegrationTests/main
-
 ```
diff --git a/unison-cli/src/Unison/Codebase/Transcript.hs b/unison-cli/src/Unison/Codebase/Transcript.hs
@@ -10,7 +10,11 @@ module Unison.Codebase.Transcript
     APIRequest (..),
     pattern CMarkCodeBlock,
     Stanza,
+    InfoTags (..),
+    defaultInfoTags,
+    defaultInfoTags',
     ProcessedBlock (..),
+    CMark.Node,
   )
 where
 
@@ -24,27 +28,48 @@ type ExpectingError = Bool
 type ScratchFileName = Text
 
 data Hidden = Shown | HideOutput | HideAll
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Read, Show)
 
 data UcmLine
   = UcmCommand UcmContext Text
   | -- | Text does not include the '--' prefix.
     UcmComment Text
+  | UcmOutputLine Text
+  deriving (Eq, Show)
 
 -- | Where a command is run: a project branch (myproject/mybranch>).
 data UcmContext
   = UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
+  deriving (Eq, Show)
 
 data APIRequest
   = GetRequest Text
   | APIComment Text
+  | APIResponseLine Text
+  deriving (Eq, Show)
 
 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 InfoTags a = InfoTags
+  { hidden :: Hidden,
+    expectingError :: ExpectingError,
+    generated :: Bool,
+    additionalTags :: a
+  }
+  deriving (Eq, Ord, Read, Show)
+
+defaultInfoTags :: a -> InfoTags a
+defaultInfoTags = InfoTags Shown 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
+defaultInfoTags' = defaultInfoTags mempty
+
 data ProcessedBlock
-  = Ucm Hidden ExpectingError [UcmLine]
-  | Unison Hidden ExpectingError (Maybe ScratchFileName) Text
-  | API [APIRequest]
+  = Ucm (InfoTags ()) [UcmLine]
+  | Unison (InfoTags (Maybe ScratchFileName)) Text
+  | API (InfoTags ()) [APIRequest]
+  deriving (Eq, Show)
diff --git a/unison-cli/src/Unison/Codebase/Transcript/Parser.hs b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs
@@ -3,12 +3,8 @@ module Unison.Codebase.Transcript.Parser
   ( -- * printing
     formatAPIRequest,
     formatUcmLine,
-    formatStanza,
-    formatNode,
-    formatProcessedBlock,
-
-    -- * conversion
-    processedBlockToNode,
+    formatInfoString,
+    formatStanzas,
 
     -- * parsing
     stanzas,
@@ -22,40 +18,43 @@ module Unison.Codebase.Transcript.Parser
 where
 
 import CMark qualified
+import Data.Bool (bool)
 import Data.Char qualified as Char
 import Data.Text qualified as Text
 import Text.Megaparsec qualified as P
-import Unison.Codebase.Transcript
+import Text.Megaparsec.Char qualified as P
+import Unison.Codebase.Transcript hiding (expectingError, generated, hidden)
 import Unison.Prelude
 import Unison.Project (fullyQualifiedProjectAndBranchNamesParser)
 
+padIfNonEmpty :: Text -> Text
+padIfNonEmpty line = if Text.null line then line else "  " <> line
+
 formatAPIRequest :: APIRequest -> Text
 formatAPIRequest = \case
-  GetRequest txt -> "GET " <> txt
-  APIComment txt -> "-- " <> txt
+  GetRequest txt -> "GET " <> txt <> "\n"
+  APIComment txt -> "--" <> txt <> "\n"
+  APIResponseLine txt -> Text.unlines . fmap padIfNonEmpty $ Text.lines txt
 
 formatUcmLine :: UcmLine -> Text
 formatUcmLine = \case
-  UcmCommand context txt -> formatContext context <> "> " <> txt
-  UcmComment txt -> "--" <> txt
+  UcmCommand context txt -> formatContext context <> "> " <> txt <> "\n"
+  UcmComment txt -> "--" <> txt <> "\n"
+  UcmOutputLine txt -> Text.unlines . fmap padIfNonEmpty $ Text.lines 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
+formatStanzas :: [Stanza] -> Text
+formatStanzas =
+  CMark.nodeToCommonmark [] Nothing . CMark.Node Nothing CMark.DOCUMENT . fmap (either id 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
+  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
+  where
+    mkNode formatA lang = CMarkCodeBlock Nothing . formatInfoString formatA lang
 
 type P = P.Parsec Void Text
 
@@ -72,79 +71,94 @@ stanzas srcName =
       _ -> pure $ Left node
 
 ucmLine :: P UcmLine
-ucmLine = ucmCommand <|> ucmComment
+ucmLine = ucmOutputLine <|> ucmComment <|> ucmCommand
   where
     ucmCommand :: P UcmLine
     ucmCommand =
       UcmCommand
-        <$> fmap UcmContextProject (P.try $ fullyQualifiedProjectAndBranchNamesParser <* lineToken (word ">"))
-        <*> P.takeWhileP Nothing (/= '\n')
-        <* spaces
+        <$> fmap
+          UcmContextProject
+          (fullyQualifiedProjectAndBranchNamesParser <* lineToken (P.chunk ">") <* nonNewlineSpaces)
+        <*> restOfLine
 
     ucmComment :: P UcmLine
     ucmComment =
       P.label "comment (delimited with “--”)" $
-        UcmComment <$> (word "--" *> P.takeWhileP Nothing (/= '\n')) <* spaces
+        UcmComment <$> (P.chunk "--" *> restOfLine)
+
+    ucmOutputLine :: P UcmLine
+    ucmOutputLine = UcmOutputLine <$> (P.chunk "  " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n")
+
+restOfLine :: P Text
+restOfLine = P.takeWhileP Nothing (/= '\n') <* P.single '\n'
 
 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)
+apiRequest =
+  GetRequest <$> (word "GET" *> spaces *> restOfLine)
+    <|> APIComment <$> (P.chunk "--" *> restOfLine)
+    <|> APIResponseLine <$> (P.chunk "  " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n")
+
+formatInfoString :: (a -> 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
+
+infoTags :: P a -> P (InfoTags a)
+infoTags p =
+  InfoTags
+    <$> lineToken hidden
+    <*> lineToken expectingError
+    <*> lineToken generated
+    <*> p
+    <* P.single '\n'
 
 -- | Parses the info string and contents of a fenced code block.
 fenced :: P (Maybe ProcessedBlock)
 fenced = do
-  fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language)
+  fenceType <- lineToken language
   case fenceType of
-    "ucm" -> do
-      hide <- hidden
-      err <- expectingError
-      pure . Ucm hide err <$> (spaces *> P.manyTill ucmLine P.eof)
-    "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.single '\n'
-      pure . Unison hide err fileName <$> P.getInput
-    "api" -> pure . API <$> (spaces *> P.manyTill apiRequest P.eof)
+    "ucm" -> fmap pure $ Ucm <$> infoTags (pure ()) <*> P.manyTill ucmLine P.eof
+    "unison" -> fmap pure $ Unison <$> infoTags (optional untilSpace1) <*> P.getInput
+    "api" -> fmap pure $ API <$> infoTags (pure ()) <*> P.manyTill apiRequest P.eof
     _ -> 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.chunk text <* P.notFollowedBy P.alphaNumChar
 
 lineToken :: P a -> P a
 lineToken p = p <* nonNewlineSpaces
 
 nonNewlineSpaces :: P ()
 nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')
 
+formatHidden :: Hidden -> Text
+formatHidden = \case
+  HideAll -> ":hide:all"
+  HideOutput -> ":hide"
+  Shown -> ""
+
 hidden :: P Hidden
 hidden =
   (HideAll <$ word ":hide:all")
     <|> (HideOutput <$ word ":hide")
     <|> pure Shown
 
+formatExpectingError :: ExpectingError -> Text
+formatExpectingError = bool "" ":error"
+
 expectingError :: P ExpectingError
 expectingError = isJust <$> optional (word ":error")
 
+formatGenerated :: ExpectingError -> Text
+formatGenerated = bool "" ":added-by-ucm"
+
+generated :: P Bool
+generated = isJust <$> optional (word ":added-by-ucm")
+
 untilSpace1 :: P Text
 untilSpace1 = P.takeWhile1P Nothing (not . Char.isSpace)