diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 51df09f996..db2ab8d6d7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -67,6 +67,7 @@ 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.DebugFoldRanges qualified as DebugFoldRanges import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject) import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) @@ -1143,6 +1144,8 @@ loop e = do for_ (Relation.toList . Branch.deepTerms $ rootBranch0) \(r, name) -> traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r) DebugTermI isVerbose hqName -> DebugDefinition.debugTerm isVerbose hqName + DebugLSPFoldRangesI -> do + DebugFoldRanges.debugFoldRanges DebugTypeI hqName -> DebugDefinition.debugDecl hqName DebugClearWatchI {} -> Cli.runTransaction Codebase.clearWatches @@ -1363,6 +1366,7 @@ inputDescription input = then pure ("debug.term.verbose " <> HQ.toText hqName) else pure ("debug.term " <> HQ.toText hqName) DebugTypeI hqName -> pure ("debug.type " <> HQ.toText hqName) + DebugLSPFoldRangesI -> pure "debug.lsp.fold-ranges" DebugNameDiffI {} -> wat DebugNumberedArgsI {} -> wat DebugTabCompletionI _input -> wat diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugFoldRanges.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugFoldRanges.hs new file mode 100644 index 0000000000..c004ca932d --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DebugFoldRanges.hs @@ -0,0 +1,61 @@ +module Unison.Codebase.Editor.HandleInput.DebugFoldRanges (debugFoldRanges) where + +import Control.Lens +import Control.Monad.Reader +import Data.Text qualified as Text +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Types qualified as LSP +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Cli.MonadUtils qualified as Cli +import Unison.Codebase.Editor.HandleInput.FormatFile (TextReplacement (..)) +import Unison.Codebase.Editor.HandleInput.FormatFile qualified as FormatFile +import Unison.Codebase.Editor.Output +import Unison.LSP.Conversions qualified as CV +import Unison.LSP.FoldingRange (foldingRangesForFile) +import Unison.Prelude +import Unison.Util.Range qualified as U + +debugFoldRanges :: Cli () +debugFoldRanges = do + Cli.Env {loadSource} <- ask + (filePath, _) <- Cli.expectLatestFile + parsedFile <- Cli.expectLatestParsedFile + let foldingRanges = + foldingRangesForFile parsedFile + & fmap + ( \fr -> + LSP.Range + (LSP.Position (fr ^. startLine) (fromMaybe 0 $ fr ^. startCharacter)) + ( case (fr ^. endCharacter) of + Just c -> LSP.Position (fr ^. endLine) c + -- If there's no end char specified, go all the way to the beginning of the next line + Nothing -> LSP.Position ((fr ^. endLine) + 1) 0 + ) + ) + sourceTxt <- + liftIO (loadSource (Text.pack filePath)) >>= \case + Cli.InvalidSourceNameError -> Cli.returnEarly $ InvalidSourceName filePath + Cli.LoadError -> Cli.returnEarly $ SourceLoadFailed filePath + Cli.LoadSuccess contents -> pure contents + Cli.respond $ AnnotatedFoldRanges $ annotateRanges sourceTxt foldingRanges + +-- | Annotate the bounds of a range within text using 《 and 》. +-- +-- Useful for checking that computed ranges make sense against the source text. +-- +-- >>> annotateRange "one\ntwo\nthree\nfour" [ LSP.Range (LSP.Position 1 0) (LSP.Position 2 3) ] +-- "one\nee\nfour" +annotateRanges :: Text -> [LSP.Range] -> Text +annotateRanges txt ranges = + let replacements = + ranges + & foldMap + ( \(LSP.Range start end) -> + let startPos = CV.lspToUPos start + endPos = CV.lspToUPos end + in [ TextReplacement "《" (U.Range startPos startPos), + TextReplacement "》" (U.Range endPos endPos) + ] + ) + in FormatFile.applyTextReplacements replacements txt diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 34ec1981a4..296edd43df 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -222,6 +222,7 @@ data Input | DebugDumpNamespaceSimpleI | DebugTermI (Bool {- Verbose mode -}) (HQ.HashQualified Name) | DebugTypeI (HQ.HashQualified Name) + | DebugLSPFoldRangesI | 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 b646a2867e..c784d248a9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -327,6 +327,7 @@ data Output | 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 -}) + | AnnotatedFoldRanges Text | ClearScreen | PulledEmptyBranch (ReadRemoteNamespace Share.RemoteProjectBranch) | CreatedProject Bool {- randomly-generated name? -} ProjectName @@ -574,6 +575,7 @@ isFailure o = case o of DebugFuzzyOptionsNoResolver {} -> True DebugTerm {} -> False DebugDecl {} -> False + AnnotatedFoldRanges {} -> 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 c88f11378b..f3f04c28a4 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2314,6 +2314,16 @@ debugType = _ -> Left (I.help debugType) ) +debugLSPFoldRanges :: InputPattern +debugLSPFoldRanges = + InputPattern + "debug.lsp.fold-ranges" + [] + I.Hidden + [] + "Output the source from the most recently parsed file, but annotated with the computed fold ranges." + (const $ Right Input.DebugLSPFoldRangesI) + debugClearWatchCache :: InputPattern debugClearWatchCache = InputPattern @@ -3043,6 +3053,7 @@ validInputs = debugTerm, debugTermVerbose, debugType, + debugLSPFoldRanges, debugFileHashes, debugNameDiff, debugNumberedArgs, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 374865ad0f..2bd6c19f56 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1790,6 +1790,7 @@ notifyUser dir = \case <> case typ of Left builtinTxt -> "Builtin type: ##" <> P.text builtinTxt Right decl -> either (P.text . TL.toStrict . pShowNoColor) (P.text . TL.toStrict . pShowNoColor) decl + AnnotatedFoldRanges txt -> pure $ P.text txt 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 @@ -1953,15 +1954,15 @@ notifyUser dir = \case prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host RemoteProjectBranchDoesntExist'Push host projectAndBranch -> let push = P.group . P.backticked . IP.patternName $ IP.push - in pure . P.wrap $ - "The previous push target named" - <> prettyProjectAndBranchName projectAndBranch - <> "has been deleted from" - <> P.group (prettyURI host <> ".") - <> "I've deleted the invalid push target." - <> "Run the" - <> push - <> "command again to push to a new target." + in pure . P.wrap $ + "The previous push target named" + <> prettyProjectAndBranchName projectAndBranch + <> "has been deleted from" + <> P.group (prettyURI host <> ".") + <> "I've deleted the invalid push target." + <> "Run the" + <> push + <> "command again to push to a new target." RemoteProjectBranchHeadMismatch host projectAndBranch -> pure . P.wrap $ prettyProjectAndBranchName projectAndBranch diff --git a/unison-cli/src/Unison/LSP/FoldingRange.hs b/unison-cli/src/Unison/LSP/FoldingRange.hs index e9746c35f3..78d958402d 100644 --- a/unison-cli/src/Unison/LSP/FoldingRange.hs +++ b/unison-cli/src/Unison/LSP/FoldingRange.hs @@ -1,6 +1,10 @@ {-# LANGUAGE DataKinds #-} -module Unison.LSP.FoldingRange where +module Unison.LSP.FoldingRange + ( foldingRangeRequest, + foldingRangesForFile, + ) +where import Control.Lens hiding (List) import Data.Map qualified as Map @@ -12,53 +16,56 @@ import Unison.DataDeclaration qualified as DD import Unison.LSP.Conversions (annToRange) import Unison.LSP.FileAnalysis (getFileAnalysis) import Unison.LSP.Types +import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.Symbol (Symbol) import Unison.UnisonFile (UnisonFile (..)) +import Unison.UnisonFile qualified as UF import Unison.Var qualified as Var foldingRangeRequest :: Msg.TRequestMessage 'Msg.Method_TextDocumentFoldingRange -> (Either Msg.ResponseError (Msg.MessageResult 'Msg.Method_TextDocumentFoldingRange) -> Lsp ()) -> Lsp () foldingRangeRequest m respond = do - foldRanges <- foldingRangesForFile (m ^. params . textDocument . uri) + let fileUri = m ^. params . textDocument . uri + foldRanges <- + fromMaybe [] <$> runMaybeT do + FileAnalysis {parsedFile = mayParsedFile} <- getFileAnalysis fileUri + parsedFile <- hoistMaybe mayParsedFile + pure $ foldingRangesForFile parsedFile respond . Right . InL $ foldRanges -- | Return a folding range for each top-level definition -foldingRangesForFile :: Uri -> Lsp [FoldingRange] -foldingRangesForFile fileUri = - fromMaybe [] - <$> runMaybeT do - FileAnalysis {parsedFile} <- getFileAnalysis fileUri - UnisonFileId {dataDeclarationsId, effectDeclarationsId, terms, watches} <- MaybeT $ pure parsedFile - let dataFolds = - dataDeclarationsId - & Map.toList - & map \(sym, (_typ, decl)) -> (Just sym, DD.annotation decl) - let abilityFolds = - effectDeclarationsId - & Map.toList - & map \(sym, (_typ, decl)) -> (Just sym, DD.annotation . DD.toDataDecl $ decl) - let termFolds = terms & fmap \(sym, ann, _trm) -> (Just sym, ann) - let watchFolds = - watches - & fold - & fmap - ( \(_sym, ann, _trm) -> - -- We don't use the symbol here because watch symbols are often auto-generated - -- and ugly. - (Nothing, ann) - ) - let folds = - dataFolds <> abilityFolds <> termFolds <> watchFolds - let ranges = - folds - & mapMaybe \(sym, range) -> - (Text.pack . Var.nameStr <$> sym,) <$> annToRange range - pure $ - ranges <&> \(maySym, r) -> - FoldingRange - { _startLine = r ^. start . line, - _startCharacter = Just (r ^. start . character), - _endLine = r ^. end . line, - _endCharacter = Just (r ^. end . character), - _kind = Just FoldingRangeKind_Region, - _collapsedText = maySym - } +foldingRangesForFile :: UF.UnisonFile Symbol Ann -> [FoldingRange] +foldingRangesForFile UnisonFileId {dataDeclarationsId, effectDeclarationsId, terms, watches} = + let dataFolds = + dataDeclarationsId + & Map.toList + & map \(sym, (_typ, decl)) -> (Just sym, DD.annotation decl) + abilityFolds = + effectDeclarationsId + & Map.toList + & map \(sym, (_typ, decl)) -> (Just sym, DD.annotation . DD.toDataDecl $ decl) + termFolds = terms & fmap \(sym, ann, _trm) -> (Just sym, ann) + watchFolds = + watches + & fold + & fmap + ( \(_sym, ann, _trm) -> + -- We don't use the symbol here because watch symbols are often auto-generated + -- and ugly. + (Nothing, ann) + ) + folds = + dataFolds <> abilityFolds <> termFolds <> watchFolds + ranges = + folds + & mapMaybe \(sym, range) -> + (Text.pack . Var.nameStr <$> sym,) <$> annToRange range + in ranges <&> \(maySym, r) -> + FoldingRange + { _startLine = r ^. start . line, + _startCharacter = Just (r ^. start . character), + _endLine = r ^. end . line, + _endCharacter = Just (r ^. end . character), + _kind = Just FoldingRangeKind_Region, + _collapsedText = maySym + } diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d5a90ee3ff..1cf748a2a5 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -51,6 +51,7 @@ library Unison.Codebase.Editor.HandleInput.Branches Unison.Codebase.Editor.HandleInput.BranchRename Unison.Codebase.Editor.HandleInput.DebugDefinition + Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DeleteBranch Unison.Codebase.Editor.HandleInput.DeleteProject Unison.Codebase.Editor.HandleInput.EditNamespace diff --git a/unison-src/transcripts/lsp-fold-ranges.md b/unison-src/transcripts/lsp-fold-ranges.md new file mode 100644 index 0000000000..377c9170dd --- /dev/null +++ b/unison-src/transcripts/lsp-fold-ranges.md @@ -0,0 +1,33 @@ +```ucm:hide +.> builtins.mergeio +``` + +```unison:hide + +{{ Type doc }} +structural type Optional a = + None + | Some a + +{{ + Multi line + + Term doc +}} +List.map : + (a -> b) + -> [a] + -> [b] +List.map f = cases + (x +: xs) -> f x +: List.map f xs + [] -> [] + +test> z = let + x = "hello" + y = "world" + [Ok (x ++ y)] +``` + +```ucm +.> debug.lsp.fold-ranges +``` diff --git a/unison-src/transcripts/lsp-fold-ranges.output.md b/unison-src/transcripts/lsp-fold-ranges.output.md new file mode 100644 index 0000000000..51f8b4ae9e --- /dev/null +++ b/unison-src/transcripts/lsp-fold-ranges.output.md @@ -0,0 +1,52 @@ +```unison +{{ Type doc }} +structural type Optional a = + None + | Some a + +{{ + Multi line + + Term doc +}} +List.map : + (a -> b) + -> [a] + -> [b] +List.map f = cases + (x +: xs) -> f x +: List.map f xs + [] -> [] + +test> z = let + x = "hello" + y = "world" + [Ok (x ++ y)] +``` + +```ucm +.> debug.lsp.fold-ranges + + 《{{ Type doc }}》 + 《structural type Optional a = + None + | Some a》 + + 《{{ + Multi line + + Term doc + }}》 + 《List.map : + (a -> b) + -> [a] + -> [b] + List.map f = cases + (x +: xs) -> f x +: List.map f xs + [] -> []》 + + 《test> z = let + x = "hello" + y = "world" + [Ok (x ++ y)]》 + +```