⅄ trunk → 22-10-18-backticky-parser

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -1730,16 +1730,18 @@ prettyDoc2 ::
 prettyDoc2 ac tm = do
   ppe <- getPPE
   let brace p =
-        fmt S.DocDelimiter "{{"
+        if PP.isMultiLine p
-          <> PP.softbreak
+          then fmt S.DocDelimiter "{{" <> PP.newline <> p <> PP.newline <> fmt S.DocDelimiter "}}"
-          <> p
+          else fmt S.DocDelimiter "{{" <> PP.softbreak <> p <> PP.softbreak <> fmt S.DocDelimiter "}}"
-          <> PP.softbreak
-          <> fmt S.DocDelimiter "}}"
       bail tm = brace <$> pretty0 ac tm
+      contains :: Char -> Pretty SyntaxText -> Bool
+      contains c p =
+        PP.toPlainUnbroken (PP.syntaxToColor p)
+          & elem c
       -- Finds the longest run of a character and return one bigger than that
       longestRun c s =
         case filter (\s -> take 2 s == [c, c]) $
-          group (PP.toPlainUnbroken $ PP.syntaxToColor s) of
+          List.group (PP.toPlainUnbroken $ PP.syntaxToColor s) of
           [] -> 2
           x -> 1 + maximum (map length x)
       oneMore c inner = replicate (longestRun c inner) c
@@ -1773,7 +1775,12 @@ prettyDoc2 ac tm = do
           pure $ PP.text t
         (toDocCode ppe -> Just d) -> do
           inner <- rec d
-          let quotes = PP.string $ oneMore '\'' inner
+          let quotes =
+                -- Prefer ` if there aren't any in the inner text,
+                -- otherwise use one more than the longest run of ' in the inner text
+                if contains '`' inner
+                  then PP.string $ oneMore '\'' inner
+                  else PP.string "`"
           pure $ PP.group $ quotes <> inner <> quotes
         (toDocJoin ppe -> Just ds) -> foldMapM rec ds
         (toDocItalic ppe -> Just d) -> do

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -66,6 +66,7 @@ import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
 import Unison.Codebase.Editor.HandleInput.Branch (handleBranch)
 import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename)
 import Unison.Codebase.Editor.HandleInput.Branches (handleBranches)
+import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
 import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch)
 import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject)
 import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace)
@@ -1142,6 +1143,8 @@ loop e = do
                 traceM $ show name ++ ",Type," ++ Text.unpack (Reference.toText r)
               for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) ->
                 traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r)
+            DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName
+            DebugTypeI hqName -> DebugDefinition.debugDecl hqName
             DebugClearWatchI {} ->
               Cli.runTransaction Codebase.clearWatches
             DebugDoctorI {} -> do
@@ -1355,6 +1358,11 @@ inputDescription input =
     DebugDoctorI {} -> wat
     DebugDumpNamespaceSimpleI {} -> wat
     DebugDumpNamespacesI {} -> wat
+    DebugTermI verbose hqName ->
+      if verbose
+        then pure ("debug.term.verbose " <> HQ.toText hqName)
+        else pure ("debug.term " <> HQ.toText hqName)
+    DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName)
     DebugNameDiffI {} -> wat
     DebugNumberedArgsI {} -> wat
     DebugTabCompletionI _input -> wat

unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugDefinition.hs

@@ -0,0 +1,59 @@
+module Unison.Codebase.Editor.HandleInput.DebugDefinition
+  ( debugTerm,
+    debugDecl,
+  )
+where
+
+import Control.Monad.Reader
+import Unison.Cli.Monad (Cli)
+import Unison.Cli.Monad qualified as Cli
+import Unison.Cli.NamesUtils qualified as Cli
+import Unison.Codebase qualified as Codebase
+import Unison.Codebase.Editor.Output (Output (..))
+import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
+import Unison.DataDeclaration.ConstructorId (ConstructorId)
+import Unison.HashQualified qualified as HQ
+import Unison.Name (Name)
+import Unison.NamesWithHistory qualified as Names
+import Unison.Prelude
+import Unison.Reference (TermReference, TypeReference)
+import Unison.Reference qualified as Reference
+import Unison.Referent qualified as Referent
+
+debugTermReference :: Bool -> TermReference -> Cli ()
+debugTermReference verbose ref = do
+  Cli.Env {codebase} <- ask
+  case ref of
+    Reference.DerivedId refId -> do
+      Cli.runTransaction (Codebase.getTerm codebase refId) >>= \case
+        Nothing -> Cli.respond $ TermNotFound' (Reference.toShortHash ref)
+        Just term -> do
+          Cli.respond $ DebugTerm verbose (Right term)
+    Reference.Builtin builtinTxt -> do
+      Cli.respond $ DebugTerm verbose (Left builtinTxt)
+
+debugTypeReference :: TypeReference -> Maybe ConstructorId -> Cli ()
+debugTypeReference ref mayConId = do
+  Cli.Env {codebase} <- ask
+  case ref of
+    Reference.DerivedId refId -> do
+      Cli.runTransaction (Codebase.getTypeDeclaration codebase refId) >>= \case
+        Nothing -> Cli.respond $ TypeNotFound' (Reference.toShortHash ref)
+        Just decl -> do
+          Cli.respond $ DebugDecl (Right decl) mayConId
+    Reference.Builtin builtinTxt -> do
+      Cli.respond $ DebugDecl (Left builtinTxt) mayConId
+
+debugTerm :: Bool -> HQ.HashQualified Name -> Cli ()
+debugTerm verbose hqName = do
+  names <- Cli.currentNames
+  let matches = Names.lookupHQTerm Names.IncludeSuffixes hqName names
+  for_ matches \case
+    Referent.Ref termReference -> debugTermReference verbose termReference
+    Referent.Con (ConstructorReference typeRef conId) _conTyp -> debugTypeReference typeRef (Just conId)
+
+debugDecl :: HQ.HashQualified Name -> Cli ()
+debugDecl hqName = do
+  names <- Cli.currentNames
+  let matches = Names.lookupHQType Names.IncludeSuffixes hqName names
+  for_ matches \typeRef -> debugTypeReference typeRef Nothing

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -220,6 +220,8 @@ data Input
   | DebugTypecheckedUnisonFileI
   | DebugDumpNamespacesI
   | DebugDumpNamespaceSimpleI
+  | DebugTermI (Bool {- Verbose mode -}) (HQ.HashQualified Name)
+  | DebugTypeI (HQ.HashQualified Name)
   | DebugClearWatchI
   | DebugDoctorI
   | DebugNameDiffI ShortCausalHash ShortCausalHash

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -47,6 +47,7 @@ import Unison.Codebase.ShortCausalHash (ShortCausalHash)
 import Unison.Codebase.ShortCausalHash qualified as SCH
 import Unison.Codebase.Type (GitError)
 import Unison.CommandLine.InputPattern qualified as Input
+import Unison.DataDeclaration qualified as DD
 import Unison.DataDeclaration.ConstructorId (ConstructorId)
 import Unison.HashQualified qualified as HQ
 import Unison.HashQualified' qualified as HQ'
@@ -324,6 +325,8 @@ data Output
   | DisplayDebugCompletions [Completion.Completion]
   | DebugDisplayFuzzyOptions Text [String {- arg description, options -}]
   | DebugFuzzyOptionsNoResolver
+  | DebugTerm (Bool {- verbose mode -}) (Either (Text {- A builtin hash -}) (Term Symbol Ann))
+  | DebugDecl (Either (Text {- A builtin hash -}) (DD.Decl Symbol Ann)) (Maybe ConstructorId {- If 'Just' we're debugging a constructor of the given decl -})
   | ClearScreen
   | PulledEmptyBranch (ReadRemoteNamespace Share.RemoteProjectBranch)
   | CreatedProject Bool {- randomly-generated name? -} ProjectName
@@ -569,6 +572,8 @@ isFailure o = case o of
   DisplayDebugCompletions {} -> False
   DebugDisplayFuzzyOptions {} -> False
   DebugFuzzyOptionsNoResolver {} -> True
+  DebugTerm {} -> False
+  DebugDecl {} -> False
   DisplayDebugNameDiff {} -> False
   ClearScreen -> False
   PulledEmptyBranch {} -> False

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -2245,6 +2245,45 @@ debugDumpNamespaceSimple =
     "Dump the namespace to a text file"
     (const $ Right Input.DebugDumpNamespaceSimpleI)
 
+debugTerm :: InputPattern
+debugTerm =
+  InputPattern
+    "debug.term.abt"
+    []
+    I.Hidden
+    [("term", Required, exactDefinitionTermQueryArg)]
+    "View debugging information for a given term."
+    ( \case
+        [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugTerm)
+    )
+
+debugTermVerbose :: InputPattern
+debugTermVerbose =
+  InputPattern
+    "debug.term.abt.verbose"
+    []
+    I.Hidden
+    [("term", Required, exactDefinitionTermQueryArg)]
+    "View verbose debugging information for a given term."
+    ( \case
+        [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugTermVerbose)
+    )
+
+debugType :: InputPattern
+debugType =
+  InputPattern
+    "debug.type.abt"
+    []
+    I.Hidden
+    [("type", Required, exactDefinitionTypeQueryArg)]
+    "View debugging information for a given type."
+    ( \case
+        [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing
+        _ -> Left (I.help debugType)
+    )
+
 debugClearWatchCache :: InputPattern
 debugClearWatchCache =
   InputPattern
@@ -2964,6 +3003,9 @@ validInputs =
       debugDoctor,
       debugDumpNamespace,
       debugDumpNamespaceSimple,
+      debugTerm,
+      debugTermVerbose,
+      debugType,
       debugFileHashes,
       debugNameDiff,
       debugNumberedArgs,

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -21,15 +21,18 @@ import Data.Set qualified as Set
 import Data.Set.NonEmpty (NESet)
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Text.Lazy qualified as TL
 import Data.Time (UTCTime, getCurrentTime)
 import Data.Tuple (swap)
 import Data.Tuple.Extra (dupe)
 import Data.Void (absurd)
+import Debug.RecoverRTTI qualified as RTTI
 import Network.HTTP.Types qualified as Http
 import Servant.Client qualified as Servant
 import System.Console.ANSI qualified as ANSI
 import System.Console.Haskeline.Completion qualified as Completion
 import System.Directory (canonicalizePath, getHomeDirectory)
+import Text.Pretty.Simple (pShowNoColor, pStringNoColor)
 import U.Codebase.Branch (NamespaceStats (..))
 import U.Codebase.Branch.Diff (NameChanges (..))
 import U.Codebase.HashTags (CausalHash (..))
@@ -1773,6 +1776,21 @@ notifyUser dir = \case
   IntegrityCheck result -> pure $ case result of
     NoIntegrityErrors -> "🎉 No issues detected 🎉"
     IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
+  DebugTerm verbose builtinOrTerm -> pure $ case builtinOrTerm of
+    Left builtin -> "Builtin term: ##" <> P.text builtin
+    Right trm ->
+      if verbose
+        then P.text . TL.toStrict . pStringNoColor $ RTTI.anythingToString trm
+        else P.shown trm
+  DebugDecl typ mayConId -> do
+    let constructorMsg = case mayConId of
+          Nothing -> ""
+          Just conId -> "Constructor #" <> P.shown conId <> " of the following type:\n"
+    pure $
+      constructorMsg
+        <> case typ of
+          Left builtinTxt -> "Builtin type: ##" <> P.text builtinTxt
+          Right decl -> either (P.text . TL.toStrict . pShowNoColor) (P.text . TL.toStrict . pShowNoColor) decl
   DisplayDebugNameDiff NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} -> do
     let referentText =
           -- We don't use the constructor type in the actual output here, so there's no
@@ -2747,7 +2765,7 @@ renderEditConflicts ppe Patch {..} = do
                  then "deprecated and also replaced with"
                  else "replaced with"
              )
-            `P.hang` P.lines replacements
+          `P.hang` P.lines replacements
     formatTermEdits ::
       (Reference.TermReference, Set TermEdit.TermEdit) ->
       Numbered Pretty
@@ -2762,7 +2780,7 @@ renderEditConflicts ppe Patch {..} = do
                  then "deprecated and also replaced with"
                  else "replaced with"
              )
-            `P.hang` P.lines replacements
+          `P.hang` P.lines replacements
     formatConflict ::
       Either
         (Reference, Set TypeEdit.TypeEdit)

unison-cli/unison-cli.cabal

@@ -50,6 +50,7 @@ library
       Unison.Codebase.Editor.HandleInput.Branch
       Unison.Codebase.Editor.HandleInput.Branches
       Unison.Codebase.Editor.HandleInput.BranchRename
+      Unison.Codebase.Editor.HandleInput.DebugDefinition
       Unison.Codebase.Editor.HandleInput.DeleteBranch
       Unison.Codebase.Editor.HandleInput.DeleteProject
       Unison.Codebase.Editor.HandleInput.EditNamespace

unison-src/transcripts-round-trip/main.output.md

@@ -166,7 +166,8 @@ fix_2224b = cases
 
 fix_2271 : Doc2
 fix_2271 =
-  {{ # Full doc body indented
+  {{
+  # Full doc body indented
   
     ``` raw
     myVal1 = 42 
@@ -179,7 +180,8 @@ fix_2271 =
     indented2="this is two indents"
     ```
     
-    I am two spaces over }}
+    I am two spaces over
+  }}
 
 Fix_2337.f : Fix_2337 -> Boolean
 Fix_2337.f = cases Fix_2337 a b -> a
@@ -304,10 +306,12 @@ fix_4384b = {{ {{ docExampleBlock 0 '99 }} }}
 fix_4384c : Doc2
 fix_4384c =
   use Nat +
-  {{ {{ docExampleBlock 0 do
+  {{
+  {{ docExampleBlock 0 do
     x = 1
     y = 2
-    x + y }} }}
+    x + y }}
+  }}
 
 fix_4384d : Doc2
 fix_4384d =
@@ -432,11 +436,13 @@ multiline_list =
 
 nested_fences : Doc2
 nested_fences =
-  {{ ```` raw
+  {{
+  ```` raw
   ```unison
   r = "boopydoo"
   ```
-  ```` }}
+  ````
+  }}
 
 raw_a : Text
 raw_a =

unison-src/transcripts-using-base/doc.output.md

@@ -112,7 +112,7 @@ and the rendered output using `display`:
       section elements.
       
       Text can be **bold**, __italicized__, ~~strikethrough~~,
-      or ''monospaced'' (or ''monospaced'').
+      or `monospaced` (or `monospaced`).
       
       You can link to Unison terms, types, and external URLs:
       
@@ -122,7 +122,7 @@ and the rendered output using `display`:
         [a named term link]({Some}). Term links are handy for
         linking to other documents!
       
-      You can use ''{{ .. }}'' to escape out to regular Unison
+      You can use `{{ .. }}` to escape out to regular Unison
       syntax, for instance {{ docWord "__not bold__" }}. This is
       useful for creating documents programmatically or just
       including other documents.
@@ -164,9 +164,9 @@ and the rendered output using `display`:
     
       ## Bulleted lists
       
-         Bulleted lists can use ''+'', ''-'', or ''*'' for the
+         Bulleted lists can use `+`, `-`, or `*` for the bullets
-         bullets (though the choice will be normalized away by
+         (though the choice will be normalized away by the
-         the pretty-printer). They can be nested, to any depth:
+         pretty-printer). They can be nested, to any depth:
          
          * A
          * B
@@ -331,9 +331,9 @@ and the rendered output using `display`:
          You can include typechecked code snippets inline, for
          instance:
          
-         * {{ docExample 2 '(f x -> f x + sqr 1) }} - the ''2''
+         * {{ docExample 2 '(f x -> f x + sqr 1) }} - the `2`
            says to ignore the first two arguments when
-           rendering. In richer renderers, the ''sqr'' link will
+           rendering. In richer renderers, the `sqr` link will
            be clickable.
          * If your snippet expression is just a single function
            application, you can put it in double backticks, like
@@ -456,7 +456,7 @@ and the rendered output using `display`:
     {{
     There are also asides, callouts, tables, tooltips, and more.
     These don't currently have special syntax; just use the
-    ''{{ }}'' syntax to call these functions directly.
+    `{{ }}` syntax to call these functions directly.
     
         @signatures{docAside, docCallout, docBlockquote, docTooltip, docTable}
     
@@ -553,7 +553,8 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub
 
   doc.guide : Doc2
   doc.guide =
-    {{ # Unison computable documentation
+    {{
+    # Unison computable documentation
     
       {{ basicFormatting }}
       
@@ -565,7 +566,8 @@ Lastly, it's common to build longer documents including subdocuments via `{{ sub
       
       {{ nonUnisonCodeBlocks }}
       
-      {{ otherElements }} }}
+      {{ otherElements }}
+    }}
 
 .> display doc.guide
 

unison-src/transcripts/debug-definitions.md

@@ -0,0 +1,28 @@
+```ucm:hide
+.> builtins.merge
+```
+
+```unison:hide
+x = 30
+
+y : Nat
+y = 
+  z = x + 2
+  z + 10
+
+structural type Optional a = Some a | None
+
+ability Ask a where
+  ask : a
+```
+
+```ucm
+.> add
+.> debug.term.abt Nat.+
+.> debug.term.abt y
+.> debug.term.abt Some
+.> debug.term.abt ask
+.> debug.type.abt Nat
+.> debug.type.abt Optional
+.> debug.type.abt Ask
+```

unison-src/transcripts/debug-definitions.output.md

@@ -0,0 +1,154 @@
+```unison
+x = 30
+
+y : Nat
+y = 
+  z = x + 2
+  z + 10
+
+structural type Optional a = Some a | None
+
+ability Ask a where
+  ask : a
+```
+
+```ucm
+.> add
+
+  ⍟ I've added these definitions:
+  
+    ability Ask a
+    structural type Optional a
+      (also named builtin.Optional)
+    x : Nat
+    y : Nat
+
+.> debug.term.abt Nat.+
+
+  Builtin term: ##Nat.+
+
+.> debug.term.abt y
+
+  (let Ref(ReferenceBuiltin "Nat.+") Ref(ReferenceDerived (Id "qpo3o788girkkbb43uf6ggqberfduhtnqbt7096eojlrp27jieco09mdasb7b0b06ej9hj60a00nnbbdo8he0b4e0m7vtopifiuhdig" 0)) 2 in (User "z". Ref(ReferenceBuiltin "Nat.+") (Var User "z") 10)):ReferenceBuiltin "Nat"
+
+.> debug.term.abt Some
+
+  Constructor #0 of the following type:
+  DataDeclaration
+      { modifier = Structural
+      , annotation = External
+      , bound =
+          [ User "a" ]
+      , constructors' =
+          [
+              ( External
+              , User "Constructor0"
+              ,
+                  ( User "a". Var User "a" -> ReferenceDerived
+                      ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 )
+                      ( Var User "a" )
+                  )
+              )
+          ,
+              ( External
+              , User "Constructor1"
+              ,
+                  ( User "a". ReferenceDerived
+                      ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 )
+                      ( Var User "a" )
+                  )
+              )
+          ]
+      }
+
+.> debug.term.abt ask
+
+  Constructor #0 of the following type:
+  EffectDeclaration
+      { toDataDecl = DataDeclaration
+          { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh"
+          , annotation = External
+          , bound =
+              [ User "a" ]
+          , constructors' =
+              [
+                  ( External
+                  , User "Constructor0"
+                  ,
+                      ( User "a".
+                          (
+                              {
+                                  [ ReferenceDerived
+                                      ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 )
+                                      ( Var User "a" )
+                                  ]
+                              } Var User "a"
+                          )
+                      )
+                  )
+              ]
+          }
+      }
+
+.> debug.type.abt Nat
+
+  Builtin type: ##Nat
+
+.> debug.type.abt Optional
+
+  DataDeclaration
+      { modifier = Structural
+      , annotation = External
+      , bound =
+          [ User "a" ]
+      , constructors' =
+          [
+              ( External
+              , User "Constructor0"
+              ,
+                  ( User "a". Var User "a" -> ReferenceDerived
+                      ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 )
+                      ( Var User "a" )
+                  )
+              )
+          ,
+              ( External
+              , User "Constructor1"
+              ,
+                  ( User "a". ReferenceDerived
+                      ( Id "nirp5os0q69o4e1u9p3t6mmq6l6otluefi3ksm7dhm0diidjvkkgl8o9bvnflbj0sanuvdusf34f1qrins3ktcaglpcqv9oums2slsg" 0 )
+                      ( Var User "a" )
+                  )
+              )
+          ]
+      }
+
+.> debug.type.abt Ask
+
+  EffectDeclaration
+      { toDataDecl = DataDeclaration
+          { modifier = Unique "a1ns7cunv2dvjmum0q8jbc54g6811cbh"
+          , annotation = External
+          , bound =
+              [ User "a" ]
+          , constructors' =
+              [
+                  ( External
+                  , User "Constructor0"
+                  ,
+                      ( User "a".
+                          (
+                              {
+                                  [ ReferenceDerived
+                                      ( Id "d8m1kmiscgfrl5n9ruvq1432lntfntl7nnao45qlk2uqhparm0uq2im0kbspu6u6kv65hd0i5oljq9m4b78peh5ekpma7gkihtsmfh0" 0 )
+                                      ( Var User "a" )
+                                  ]
+                              } Var User "a"
+                          )
+                      )
+                  )
+              ]
+          }
+      }
+
+```

unison-src/transcripts/doc2.md

@@ -0,0 +1,118 @@
+# Test parsing and round-trip of doc2 syntax elements
+
+```ucm:hide
+.> builtins.mergeio
+```
+
+```unison:hide
+otherDoc : a -> Doc2
+otherDoc _ = {{ yo }}
+
+otherTerm : Nat
+otherTerm = 99
+
+fulldoc : Doc2
+fulldoc =
+  use Nat +
+  {{
+Heres some text with a
+soft line break
+
+hard line break
+
+Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block `1 + 2`
+
+Should print with appropriate fences for the contents:
+
+`No fancy quotes`
+
+'' There are `backticks` in here ''
+
+''' There are `backticks` and ''quotes'' in here '''
+
+# Heading
+
+## Heading 2
+
+Term Link: {otherTerm}
+
+Type Link: {type Optional}
+
+Term source:
+
+@source{term}
+
+Term signature:
+
+@signature{term}
+
+* List item
+
+Inline code:
+
+`` 1 + 2 ``
+
+` "doesn't typecheck" + 1 `
+
+[Link](https://unison-lang.org)
+
+![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png)
+
+Horizontal rule
+
+---
+
+Video
+
+{{
+Special
+    (Embed
+    (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")])))
+}}
+
+Transclusion/evaluation:
+
+{{ otherDoc (a -> Word a) }}
+
+---
+
+The following markdown features aren't supported by the Doc format yet, but maybe will someday
+
+
+> Block quote
+
+
+Table
+
+| Header 1 | Header 2 | 
+| -------- | -------- | 
+| Cell 1 | Cell 2 | 
+
+
+    Indented Code block
+
+'''
+    Exact whitespace should be preserved across multiple updates. Don't mess with the logo!
+
+     _____     _
+    |  |  |___|_|___ ___ ___
+    |  |  |   | |_ -| . |   |
+    |_____|_|_|_|___|___|_|_|
+
+    Line with no whitespace:
+
+    Should have one full trailing newline below here:
+
+'''
+
+Inline '' text literal with 1 space of padding '' in the middle of a sentence.
+
+
+}}
+```
+
+Format it to check that everything pretty-prints in a valid way.
+
+```ucm
+.> debug.format
+```

unison-src/transcripts/doc2.output.md

@@ -0,0 +1,217 @@
+# Test parsing and round-trip of doc2 syntax elements
+
+```unison
+otherDoc : a -> Doc2
+otherDoc _ = {{ yo }}
+
+otherTerm : Nat
+otherTerm = 99
+
+fulldoc : Doc2
+fulldoc =
+  use Nat +
+  {{
+Heres some text with a
+soft line break
+
+hard line break
+
+Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code block `1 + 2`
+
+Should print with appropriate fences for the contents:
+
+`No fancy quotes`
+
+'' There are `backticks` in here ''
+
+''' There are `backticks` and ''quotes'' in here '''
+
+# Heading
+
+## Heading 2
+
+Term Link: {otherTerm}
+
+Type Link: {type Optional}
+
+Term source:
+
+@source{term}
+
+Term signature:
+
+@signature{term}
+
+* List item
+
+Inline code:
+
+`` 1 + 2 ``
+
+` "doesn't typecheck" + 1 `
+
+[Link](https://unison-lang.org)
+
+![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png)
+
+Horizontal rule
+
+---
+
+Video
+
+{{
+Special
+    (Embed
+    (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")])))
+}}
+
+Transclusion/evaluation:
+
+{{ otherDoc (a -> Word a) }}
+
+---
+
+The following markdown features aren't supported by the Doc format yet, but maybe will someday
+
+
+> Block quote
+
+
+Table
+
+| Header 1 | Header 2 | 
+| -------- | -------- | 
+| Cell 1 | Cell 2 | 
+
+
+    Indented Code block
+
+'''
+    Exact whitespace should be preserved across multiple updates. Don't mess with the logo!
+
+     _____     _
+    |  |  |___|_|___ ___ ___
+    |  |  |   | |_ -| . |   |
+    |_____|_|_|_|___|___|_|_|
+
+    Line with no whitespace:
+
+    Should have one full trailing newline below here:
+
+'''
+
+Inline '' text literal with 1 space of padding '' in the middle of a sentence.
+
+
+}}
+```
+
+Format it to check that everything pretty-prints in a valid way.
+
+```ucm
+.> debug.format
+
+```
+```unison:added-by-ucm scratch.u
+otherDoc : a -> Doc2
+otherDoc _ = {{ yo }}
+
+otherTerm : Nat
+otherTerm = 99
+
+fulldoc : Doc2
+fulldoc =
+  use Nat +
+  {{
+  Heres some text with a soft line break
+  
+  hard line break
+  
+  Here's a cool **BOLD** __italic__ ~~strikethrough~~ thing with an inline code
+  block `1 + 2`
+  
+  Should print with appropriate fences for the contents:
+  
+  `No fancy quotes`
+  
+  '' There are `backticks` in here ''
+  
+  ''' There are `backticks` and ''quotes'' in here '''
+  
+  # Heading
+  
+    ## Heading 2
+    
+       Term Link: {otherTerm}
+       
+       Type Link: {type Optional}
+       
+       Term source:
+       
+           @source{term}
+       
+       Term signature:
+       
+           @signature{term}
+       
+       * List item
+       
+       Inline code:
+       
+       `` 1 + 2 ``
+       
+       ` "doesn't typecheck" + 1 `
+       
+       [Link](https://unison-lang.org)
+       
+       ![Image](https://share-next.unison-lang.org/static/unison-logo-circle.png)
+       
+       Horizontal rule
+       
+       ---
+       
+       Video
+       
+       {{
+       Special
+         (Embed
+           (Any (Video [MediaSource "test.mp4" None] [("poster", "test.png")])))
+       }}
+       
+       Transclusion/evaluation:
+       
+       {{ otherDoc (a -> Word a) }}
+       
+       ---
+       
+       The following markdown features aren't supported by the Doc format yet,
+       but maybe will someday
+       
+       > Block quote
+       
+       Table
+       
+       | Header 1 | Header 2 | | -------- | -------- | | Cell 1 | Cell 2 |
+       
+       Indented Code block
+       
+       '''
+           Exact whitespace should be preserved across multiple updates. Don't mess with the logo!
+       
+            _____     _
+           |  |  |___|_|___ ___ ___
+           |  |  |   | |_ -| . |   |
+           |_____|_|_|_|___|___|_|_|
+       
+           Line with no whitespace:
+       
+           Should have one full trailing newline below here:
+       
+       '''
+       
+       Inline ` text literal with 1 space of padding ` in the middle of a
+       sentence.
+  }}
+```
+

unison-src/transcripts/formatter.output.md

@@ -52,11 +52,13 @@ type Two = One Nat | Two Text
 ```
 ```unison:added-by-ucm scratch.u
 x.doc =
-  {{ # Doc This is a **doc**!
+  {{
+  # Doc This is a **doc**!
   
     term link {x}
     
-    type link {type Optional} }}
+    type link {type Optional}
+  }}
 x : Nat -> Nat
 x y =
   use Nat +
@@ -70,11 +72,13 @@ oneLiner = {{ one liner }}
 
 -- Before
 explicit.doc =
-  {{ # Here's a top-level doc
+  {{
+  # Here's a top-level doc
   
     With a paragraph
     
-    Or two }}
+    Or two
+  }}
 -- After
 
 Thing.doc = {{ A doc before an ability }}

unison-syntax/package.yaml

@@ -9,6 +9,7 @@ dependencies:
   - bytes
   - containers
   - cryptonite
+  - extra
   - lens
   - megaparsec
   - mtl

unison-syntax/src/Unison/Syntax/Lexer.hs

@@ -27,8 +27,10 @@ where
 
 import Control.Monad.State qualified as S
 import Data.Char (isAlphaNum, isControl, isDigit, isSpace, ord, toLower)
-import Data.List (intercalate, isPrefixOf)
+import Data.List qualified as List
+import Data.List.Extra qualified as List
 import Data.List.NonEmpty qualified as Nel
+import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as Text
@@ -404,7 +406,7 @@ lexemes' eof =
         body = join <$> P.many (sectionElem <* CP.space)
         sectionElem = section <|> fencedBlock <|> list <|> paragraph
         paragraph = wrap "syntax.docParagraph" $ join <$> spaced leaf
-        reserved word = isPrefixOf "}}" word || all (== '#') word
+        reserved word = List.isPrefixOf "}}" word || all (== '#') word
 
         wordy closing = wrap "syntax.docWord" . tok . fmap Textual . P.try $ do
           let end =
@@ -497,28 +499,26 @@ lexemes' eof =
 
         verbatim =
           P.label "code (examples: ''**unformatted**'', `words` or '''_words_''')" $ do
-            Token txt start stop <- tokenP do
+            Token originalText start stop <- tokenP do
               -- a single backtick followed by a non-backtick is treated as monospaced
               let tick = P.try (lit "`" <* P.lookAhead (P.satisfy (/= '`')))
               -- also two or more ' followed by that number of closing '
               quotes <- tick <|> (lit "''" <+> P.takeWhileP Nothing (== '\''))
               P.someTill P.anySingle (lit quotes)
-            if all isSpace $ takeWhile (/= '\n') txt
+            let isMultiLine = line start /= line stop
-              then
+            if isMultiLine
+              then do
+                let trimmed = (trimAroundDelimiters originalText)
+                let txt = trimIndentFromVerbatimBlock (column start - 1) trimmed
+                -- If it's a multi-line verbatim block we trim any whitespace representing
+                -- indentation from the pretty-printer. See 'trimIndentFromVerbatimBlock'
                 wrap "syntax.docVerbatim" $
                   wrap "syntax.docWord" $
-                    pure [Token (Textual (trim txt)) start stop]
+                    pure [Token (Textual txt) start stop]
               else
                 wrap "syntax.docCode" $
                   wrap "syntax.docWord" $
-                    pure [Token (Textual txt) start stop]
+                    pure [Token (Textual originalText) start stop]
-
-        trim = f . f
-          where
-            f = reverse . dropThru
-            dropThru = dropNl . dropWhile (\ch -> isSpace ch && ch /= '\n')
-            dropNl ('\n' : t) = t
-            dropNl as = as
 
         exampleInline =
           P.label "inline code (examples: ``List.map f xs``, ``[1] :+ 2``)" $
@@ -589,7 +589,7 @@ lexemes' eof =
                     | isSpace c && (not $ isControl c) =
                         skip (col - 1) r
                   skip _ s = s
-               in intercalate "\n" $ skip column <$> lines s
+               in List.intercalate "\n" $ skip column <$> lines s
 
             other = wrap "syntax.docCodeBlock" $ do
               column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel
@@ -602,7 +602,7 @@ lexemes' eof =
               _ <- void CP.eol
               verbatim <-
                 tok $
-                  Textual . uncolumn column tabWidth . trim
+                  Textual . uncolumn column tabWidth . trimAroundDelimiters
                     <$> P.someTill P.anySingle ([] <$ lit fence)
               pure (name <> verbatim)
 
@@ -816,7 +816,7 @@ lexemes' eof =
       pure $ case tweak (lines s) of
         [] -> s
         ls
-          | all (\l -> isPrefixOf leading l || all isSpace l) ls -> intercalate "\n" (drop (length leading) <$> ls)
+          | all (\l -> List.isPrefixOf leading l || all isSpace l) ls -> List.intercalate "\n" (drop (length leading) <$> ls)
           | otherwise -> s
     quotedSingleLine = char '"' *> P.manyTill (LP.charLiteral <|> sp) (char '"')
       where
@@ -1017,6 +1017,108 @@ lexemes' eof =
           where
             ok c = isDelayOrForce c || isSpace c || isAlphaNum c || Set.member c delimiters || c == '\"'
 
+-- | If it's a multi-line verbatim block we trim any whitespace representing
+-- indentation from the pretty-printer.
+--
+-- E.g.
+--
+-- @@
+-- {{
+--   # Heading
+--     '''
+--     code
+--       indented
+--     '''
+-- }}
+-- @@
+--
+-- Should lex to the text literal "code\n  indented".
+--
+-- If there's text in the literal that has LESS trailing whitespace than the
+-- opening delimiters, we don't trim it at all. E.g.
+--
+-- @@
+-- {{
+--   # Heading
+--     '''
+--   code
+--     '''
+-- }}
+-- @@
+--
+--  Is parsed as "  code".
+--
+--  Trim the expected amount of whitespace from a text literal:
+--  >>> trimIndentFromVerbatimBlock 2 "  code\n    indented"
+-- "code\n  indented"
+--
+-- If the text literal has less leading whitespace than the opening delimiters,
+-- leave it as-is
+-- >>> trimIndentFromVerbatimBlock 2 "code\n  indented"
+-- "code\n  indented"
+trimIndentFromVerbatimBlock :: Int -> String -> String
+trimIndentFromVerbatimBlock leadingSpaces txt = fromMaybe txt $ do
+  List.intercalate "\n" <$> for (lines txt) \line -> do
+    -- If any 'stripPrefix' fails, we fail and return the unaltered text
+    case List.stripPrefix (replicate leadingSpaces ' ') line of
+      Just stripped -> Just stripped
+      Nothing ->
+        -- If it was a line with all white-space, just use an empty line,
+        -- this can happen easily in editors which trim trailing whitespace.
+        if all isSpace line
+          then Just ""
+          else Nothing
+
+-- Trim leading/trailing whitespace from around delimiters, e.g.
+--
+-- {{
+--   '''___ <- whitespace here including newline
+--   text block
+-- 👇 or here
+-- __'''
+-- }}
+-- >>> trimAroundDelimiters "  \n  text block \n  "
+-- "  text block "
+--
+-- Should leave leading and trailing line untouched if it contains non-whitespace, e.g.:
+--
+-- '''  leading whitespace
+--   text block
+-- trailing whitespace:  '''
+-- >>> trimAroundDelimiters "  leading whitespace\n  text block \ntrailing whitespace:  "
+-- "  leading whitespace\n  text block \ntrailing whitespace:  "
+--
+-- Should keep trailing newline if it's the only thing on the line, e.g.:
+--
+-- '''
+-- newline below
+--
+-- '''
+-- >>> trimAroundDelimiters "\nnewline below\n\n"
+-- "newline below\n\n"
+trimAroundDelimiters :: String -> String
+trimAroundDelimiters txt =
+  txt
+    & ( \s ->
+          List.breakOn "\n" s
+            & \case
+              (prefix, suffix)
+                | all isSpace prefix -> drop 1 suffix
+                | otherwise -> prefix <> suffix
+      )
+    & ( \s ->
+          List.breakOnEnd "\n" s
+            & \case
+              (_prefix, "") -> s
+              (prefix, suffix)
+                | all isSpace suffix -> dropTrailingNewline prefix
+                | otherwise -> prefix <> suffix
+      )
+  where
+    dropTrailingNewline = \case
+      [] -> []
+      (x : xs) -> NonEmpty.init (x NonEmpty.:| xs)
+
 separated :: (Char -> Bool) -> P a -> P a
 separated ok p = P.try $ p <* P.lookAhead (void (P.satisfy ok) <|> P.eof)
 
@@ -1116,7 +1218,7 @@ close' reopenBlockname open closeP = do
   case findClose open (layout env) of
     Nothing -> err pos1 (CloseWithoutMatchingOpen msgOpen (quote close))
       where
-        msgOpen = intercalate " or " (quote <$> open)
+        msgOpen = List.intercalate " or " (quote <$> open)
         quote s = "'" <> s <> "'"
     Just (_, n) -> do
       S.put (env {layout = drop n (layout env), opening = reopenBlockname})

unison-syntax/unison-syntax.cabal

@@ -68,6 +68,7 @@ library
     , bytes
     , containers
     , cryptonite
+    , extra
     , lens
     , megaparsec
     , mtl
@@ -125,6 +126,7 @@ test-suite syntax-tests
     , containers
     , cryptonite
     , easytest
+    , extra
     , lens
     , megaparsec
     , mtl