diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index fcc3b76a2..740a159bf 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -1730,16 +1730,18 @@ prettyDoc2 :: prettyDoc2 ac tm = do ppe <- getPPE let brace p = - fmt S.DocDelimiter "{{" - <> PP.softbreak - <> p - <> PP.softbreak - <> fmt S.DocDelimiter "}}" + if PP.isMultiLine p + then fmt S.DocDelimiter "{{" <> PP.newline <> p <> PP.newline <> fmt S.DocDelimiter "}}" + else fmt S.DocDelimiter "{{" <> PP.softbreak <> p <> 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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 24963a395..66cfceab2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugDefinition.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugDefinition.hs new file mode 100644 index 000000000..dd57624bd --- /dev/null +++ b/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 diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 3b0e3901f..4872b8d16 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/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 diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index c31f0ab42..e0226001d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/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 diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 34f2cc19e..d68fc7d10 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/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, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 92c070736..15b22ffa6 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/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) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 48e43fe68..d5a90ee3f 100644 --- a/unison-cli/unison-cli.cabal +++ b/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 diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index d7774d871..ce990028d 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/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 = diff --git a/unison-src/transcripts-using-base/doc.output.md b/unison-src/transcripts-using-base/doc.output.md index 892687f38..1d7c8a3f5 100644 --- a/unison-src/transcripts-using-base/doc.output.md +++ b/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 - bullets (though the choice will be normalized away by - the pretty-printer). They can be nested, to any depth: + Bulleted lists can use `+`, `-`, or `*` for the bullets + (though the choice will be normalized away by the + 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 diff --git a/unison-src/transcripts/debug-definitions.md b/unison-src/transcripts/debug-definitions.md new file mode 100644 index 000000000..471748691 --- /dev/null +++ b/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 +``` diff --git a/unison-src/transcripts/debug-definitions.output.md b/unison-src/transcripts/debug-definitions.output.md new file mode 100644 index 000000000..cb1b14d1a --- /dev/null +++ b/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" + ) + ) + ) + ] + } + } + +``` diff --git a/unison-src/transcripts/docs.md b/unison-src/transcripts/doc1.md similarity index 100% rename from unison-src/transcripts/docs.md rename to unison-src/transcripts/doc1.md diff --git a/unison-src/transcripts/docs.output.md b/unison-src/transcripts/doc1.output.md similarity index 100% rename from unison-src/transcripts/docs.output.md rename to unison-src/transcripts/doc1.output.md diff --git a/unison-src/transcripts/doc2.md b/unison-src/transcripts/doc2.md new file mode 100644 index 000000000..278cc8f49 --- /dev/null +++ b/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 +``` diff --git a/unison-src/transcripts/doc2.output.md b/unison-src/transcripts/doc2.output.md new file mode 100644 index 000000000..e303b639a --- /dev/null +++ b/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. + }} +``` + diff --git a/unison-src/transcripts/formatter.output.md b/unison-src/transcripts/formatter.output.md index 904095a21..e0132020a 100644 --- a/unison-src/transcripts/formatter.output.md +++ b/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 }} diff --git a/unison-syntax/package.yaml b/unison-syntax/package.yaml index 9763c9cc3..8e1a478ba 100644 --- a/unison-syntax/package.yaml +++ b/unison-syntax/package.yaml @@ -9,6 +9,7 @@ dependencies: - bytes - containers - cryptonite + - extra - lens - megaparsec - mtl diff --git a/unison-syntax/src/Unison/Syntax/Lexer.hs b/unison-syntax/src/Unison/Syntax/Lexer.hs index 919fa5c64..2f860ab6a 100644 --- a/unison-syntax/src/Unison/Syntax/Lexer.hs +++ b/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 - then + let isMultiLine = line start /= line stop + 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] - - trim = f . f - where - f = reverse . dropThru - dropThru = dropNl . dropWhile (\ch -> isSpace ch && ch /= '\n') - dropNl ('\n' : t) = t - dropNl as = as + pure [Token (Textual originalText) start stop] 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}) diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index 1060586e5..9c3241e39 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/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