mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
parent
3035766325
commit
b7be8ded03
@ -6,9 +6,9 @@
|
||||
|
||||
Supported features:
|
||||
|
||||
* Show type on hover
|
||||
* Autocompletion
|
||||
* Inline type and parser error messages
|
||||
* NO autocomplete yet, but soon.
|
||||
* Show type on hover
|
||||
|
||||
Notes:
|
||||
|
||||
@ -30,7 +30,8 @@ Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the fo
|
||||
"unison": {
|
||||
"filetypes": ["unison"],
|
||||
"host": "127.0.0.1",
|
||||
"port": 5757
|
||||
"port": 5757,
|
||||
"settings": {}
|
||||
}
|
||||
}
|
||||
```
|
||||
@ -39,5 +40,25 @@ Note that you'll need to start UCM _before_ you try connecting to it in your edi
|
||||
|
||||
### VSCode
|
||||
|
||||
VSCode doesn't allow customizing LSP implementations without an extension,
|
||||
Hang tight, one will be available soon!
|
||||
Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison).
|
||||
|
||||
|
||||
### Other Editors
|
||||
|
||||
If your editor provides a mechanism for connecting to a host and port, provide a host of `127.0.0.1` and port `5757`.
|
||||
|
||||
If your editor requires a command to run, you can provide the command `nc localhost 5757` on Mac, or `netcat localhost 5757` on linux.
|
||||
Note that some editors require passing the command and arguments as separate parameters.
|
||||
|
||||
## Configuration
|
||||
|
||||
Supported settings and their defaults. See information for your language server client about where to provide these.
|
||||
|
||||
```json
|
||||
{
|
||||
// The number of completions the server should collect and send based on a single query.
|
||||
// Increasing this limit will provide more completion results, but at the cost of being slower to respond.
|
||||
// If explicitly set to `null` the server will return ALL completions available.
|
||||
"maxCompletions": 100
|
||||
}
|
||||
```
|
||||
|
@ -28,6 +28,7 @@ dependencies:
|
||||
- exceptions
|
||||
- extra
|
||||
- filepath
|
||||
- free
|
||||
- fuzzyfind
|
||||
- friendly-time
|
||||
- generic-lens
|
||||
|
@ -8,7 +8,6 @@ module Unison.LSP where
|
||||
import Colog.Core (LogAction (LogAction))
|
||||
import qualified Colog.Core as Colog
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson hiding (Options, defaultOptions)
|
||||
import GHC.IO.Exception (ioe_errno)
|
||||
import qualified Ki
|
||||
import qualified Language.LSP.Logging as LSP
|
||||
@ -27,6 +26,8 @@ import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.CancelRequest (cancelRequestHandler)
|
||||
import Unison.LSP.CodeAction (codeActionHandler)
|
||||
import Unison.LSP.Completion (completionHandler)
|
||||
import qualified Unison.LSP.Configuration as Config
|
||||
import qualified Unison.LSP.FileAnalysis as Analysis
|
||||
import Unison.LSP.FoldingRange (foldingRangeRequest)
|
||||
import qualified Unison.LSP.HandlerUtils as Handlers
|
||||
@ -65,7 +66,7 @@ spawnLsp codebase runtime latestBranch latestPath = TCP.withSocketsDo do
|
||||
case Errno <$> ioe_errno ioerr of
|
||||
Just errNo
|
||||
| errNo == eADDRINUSE -> do
|
||||
putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
|
||||
putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
|
||||
_ -> do
|
||||
Debug.debugM Debug.LSP "LSP Exception" ioerr
|
||||
Debug.debugM Debug.LSP "LSP Errno" (ioe_errno ioerr)
|
||||
@ -85,21 +86,14 @@ serverDefinition ::
|
||||
ServerDefinition Config
|
||||
serverDefinition vfsVar codebase runtime scope latestBranch latestPath =
|
||||
ServerDefinition
|
||||
{ defaultConfig = lspDefaultConfig,
|
||||
onConfigurationChange = lspOnConfigurationChange,
|
||||
{ defaultConfig = defaultLSPConfig,
|
||||
onConfigurationChange = Config.updateConfig,
|
||||
doInitialize = lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath,
|
||||
staticHandlers = lspStaticHandlers,
|
||||
interpretHandler = lspInterpretHandler,
|
||||
options = lspOptions
|
||||
}
|
||||
|
||||
-- | Detect user LSP configuration changes.
|
||||
lspOnConfigurationChange :: Config -> Value -> Either Text Config
|
||||
lspOnConfigurationChange _ _ = pure Config
|
||||
|
||||
lspDefaultConfig :: Config
|
||||
lspDefaultConfig = Config
|
||||
|
||||
-- | Initialize any context needed by the LSP server
|
||||
lspDoInitialize ::
|
||||
MVar VFS ->
|
||||
@ -120,6 +114,7 @@ lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath lspContext
|
||||
parseNamesCacheVar <- newTVarIO mempty
|
||||
currentPathCacheVar <- newTVarIO Path.absoluteEmpty
|
||||
cancellationMapVar <- newTVarIO mempty
|
||||
completionsVar <- newTVarIO mempty
|
||||
let env = Env {ppeCache = readTVarIO ppeCacheVar, parseNamesCache = readTVarIO parseNamesCacheVar, currentPathCache = readTVarIO currentPathCacheVar, ..}
|
||||
let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM
|
||||
Ki.fork scope (lspToIO Analysis.fileAnalysisWorker)
|
||||
@ -141,6 +136,7 @@ lspRequestHandlers =
|
||||
& SMM.insert STextDocumentHover (mkHandler hoverHandler)
|
||||
& SMM.insert STextDocumentCodeAction (mkHandler codeActionHandler)
|
||||
& SMM.insert STextDocumentFoldingRange (mkHandler foldingRangeRequest)
|
||||
& SMM.insert STextDocumentCompletion (mkHandler completionHandler)
|
||||
where
|
||||
defaultTimeout = 10_000 -- 10s
|
||||
mkHandler ::
|
||||
@ -167,6 +163,7 @@ lspNotificationHandlers =
|
||||
& SMM.insert STextDocumentDidChange (ClientMessageHandler VFS.lspChangeFile)
|
||||
& SMM.insert SInitialized (ClientMessageHandler Notifications.initializedHandler)
|
||||
& SMM.insert SCancelRequest (ClientMessageHandler $ Notifications.withDebugging cancelRequestHandler)
|
||||
& SMM.insert SWorkspaceDidChangeConfiguration (ClientMessageHandler Config.workspaceConfigurationChanged)
|
||||
|
||||
-- | A natural transformation into IO, required by the LSP lib.
|
||||
lspInterpretHandler :: Env -> Lsp <~> IO
|
||||
|
@ -4,122 +4,238 @@
|
||||
|
||||
module Unison.LSP.Completion where
|
||||
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Reader
|
||||
import Data.String.Here.Uninterpolated (here)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Language.LSP.Types
|
||||
import Language.LSP.Types.Lens
|
||||
import qualified Text.FuzzyFind as Fuzzy
|
||||
import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.HashQualified' as HQ'
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
import Unison.Names (Names (..))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Server.Endpoints.FuzzyFind as FZF
|
||||
import qualified Unison.Server.Syntax as Server
|
||||
import qualified Unison.Server.Types as Backend
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPED
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Util.Monoid as Monoid
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
|
||||
-- | Rudimentary auto-completion handler
|
||||
--
|
||||
-- TODO:
|
||||
-- * Rewrite this to use an index rather than fuzzy searching ALL names
|
||||
-- * Respect ucm's current path
|
||||
-- * Provide namespaces as auto-complete targets
|
||||
-- * Auto-complete minimally suffixed names
|
||||
-- * Include docs in completion details?
|
||||
completionHandler :: RequestMessage 'TextDocumentCompletion -> (Either ResponseError (ResponseResult 'TextDocumentCompletion) -> Lsp ()) -> Lsp ()
|
||||
completionHandler m respond =
|
||||
respond =<< do
|
||||
mayPrefix <- VFS.completionPrefix (m ^. params)
|
||||
case mayPrefix of
|
||||
Nothing -> pure . Right . InL . List $ []
|
||||
Just (range, prefix) -> do
|
||||
matches <- expand range prefix
|
||||
let isIncomplete = True -- TODO: be smarter about this
|
||||
pure . Right . InR . CompletionList isIncomplete . List $ snippetCompletions prefix range <> matches
|
||||
respond . maybe (Right $ InL mempty) (Right . InR) =<< runMaybeT do
|
||||
(range, prefix) <- MaybeT $ VFS.completionPrefix (m ^. params)
|
||||
ppe <- PPED.suffixifiedPPE <$> lift globalPPE
|
||||
completions <- lift getCompletions
|
||||
Config {maxCompletions} <- lift getConfig
|
||||
let defMatches = matchCompletions completions prefix
|
||||
let (isIncomplete, defCompletions) =
|
||||
defMatches
|
||||
& nubOrdOn (\(p, _name, ref) -> (p, ref))
|
||||
& fmap (over _1 Path.toText)
|
||||
& case maxCompletions of
|
||||
Nothing -> (False,)
|
||||
Just n -> takeCompletions n
|
||||
let defCompletionItems =
|
||||
defCompletions
|
||||
& mapMaybe \(path, fqn, dep) ->
|
||||
let biasedPPE = PPE.biasTo [fqn] ppe
|
||||
hqName = LD.fold (PPE.types biasedPPE) (PPE.terms biasedPPE) dep
|
||||
in hqName <&> \hqName -> mkDefCompletionItem range (Name.toText fqn) path (HQ'.toText hqName) dep
|
||||
pure . CompletionList isIncomplete . List $ defCompletionItems
|
||||
where
|
||||
resultToCompletion :: Range -> Text -> FZF.FoundResult -> CompletionItem
|
||||
resultToCompletion range prefix = \case
|
||||
FZF.FoundTermResult (FZF.FoundTerm {namedTerm = Backend.NamedTerm {termName, termType}}) -> do
|
||||
(mkCompletionItem (HQ'.toText termName))
|
||||
{ _detail = (": " <>) . Text.pack . Server.toPlain <$> termType,
|
||||
_kind = Just CiVariable,
|
||||
_insertText = Text.stripPrefix prefix (HQ'.toText termName),
|
||||
_textEdit = Just $ CompletionEditText (TextEdit range (HQ'.toText termName))
|
||||
}
|
||||
FZF.FoundTypeResult (FZF.FoundType {namedType = Backend.NamedType {typeName, typeTag}}) ->
|
||||
let (detail, kind) = case typeTag of
|
||||
Backend.Ability -> ("Ability", CiInterface)
|
||||
Backend.Data -> ("Data", CiClass)
|
||||
in (mkCompletionItem (HQ'.toText typeName))
|
||||
{ _detail = Just detail,
|
||||
_kind = Just kind
|
||||
}
|
||||
expand :: Range -> Text -> Lsp [CompletionItem]
|
||||
expand range prefix = do
|
||||
-- We should probably write a different fzf specifically for completion, but for now, it
|
||||
-- expects the unique pieces of the query to be different "words".
|
||||
let query = Text.unwords . Text.splitOn "." $ prefix
|
||||
cb <- asks codebase
|
||||
lspBackend (FZF.serveFuzzyFind cb Nothing Nothing Nothing Nothing (Just $ Text.unpack query)) >>= \case
|
||||
Left _be -> pure []
|
||||
Right results ->
|
||||
pure . fmap (resultToCompletion range prefix . snd) . take 15 . sortOn (Fuzzy.score . fst) $ results
|
||||
-- Takes at most the specified number of completions, but also indicates with a boolean
|
||||
-- whether there were more completions remaining so we can pass that along to the client.
|
||||
takeCompletions :: Int -> [a] -> (Bool, [a])
|
||||
takeCompletions 0 xs = (not $ null xs, [])
|
||||
takeCompletions _ [] = (False, [])
|
||||
takeCompletions n (x : xs) = second (x :) $ takeCompletions (pred n) xs
|
||||
|
||||
snippetCompletions :: Text -> Range -> [CompletionItem]
|
||||
snippetCompletions prefix range =
|
||||
[ ("handler", handlerTemplate),
|
||||
("cases", casesTemplate),
|
||||
("match-with", matchWithTemplate)
|
||||
]
|
||||
& filter (Text.isPrefixOf prefix . fst)
|
||||
& fmap toCompletion
|
||||
where
|
||||
toCompletion :: (Text, Text) -> CompletionItem
|
||||
toCompletion (pat, snippet) =
|
||||
(mkCompletionItem pat)
|
||||
{ _insertTextFormat = Just Snippet,
|
||||
_insertTextMode = Just AdjustIndentation,
|
||||
_textEdit = Just $ CompletionEditText (TextEdit range snippet)
|
||||
}
|
||||
handlerTemplate =
|
||||
[here|
|
||||
handle${1:Ability} : Request (${1:Ability} ${2}) a -> a
|
||||
handle${1:Ability} = cases
|
||||
{${3} -> continue} -> do
|
||||
${4}
|
||||
|]
|
||||
casesTemplate =
|
||||
[here|
|
||||
cases
|
||||
${1} -> do
|
||||
${2}
|
||||
|]
|
||||
matchWithTemplate =
|
||||
[here|
|
||||
match ${1} with
|
||||
${2} -> do
|
||||
${3}
|
||||
|]
|
||||
|
||||
mkCompletionItem :: Text -> CompletionItem
|
||||
mkCompletionItem lbl =
|
||||
mkDefCompletionItem :: Range -> Text -> Text -> Text -> LabeledDependency -> CompletionItem
|
||||
mkDefCompletionItem range fqn path suffixified dep =
|
||||
CompletionItem
|
||||
{ _label = lbl,
|
||||
_kind = Nothing,
|
||||
_kind = case dep of
|
||||
LD.TypeReference _ref -> Just CiClass
|
||||
LD.TermReferent ref -> case ref of
|
||||
Referent.Con {} -> Just CiConstructor
|
||||
Referent.Ref {} -> Just CiValue,
|
||||
_tags = Nothing,
|
||||
_detail = Nothing,
|
||||
_detail = Just fqn,
|
||||
_documentation = Nothing,
|
||||
_deprecated = Nothing,
|
||||
_preselect = Nothing,
|
||||
_sortText = Nothing,
|
||||
_filterText = Nothing,
|
||||
_filterText = Just path,
|
||||
_insertText = Nothing,
|
||||
_insertTextFormat = Nothing,
|
||||
_insertTextMode = Nothing,
|
||||
_textEdit = Nothing,
|
||||
_textEdit = Just (CompletionEditText $ TextEdit range suffixified),
|
||||
_additionalTextEdits = Nothing,
|
||||
_commitCharacters = Nothing,
|
||||
_command = Nothing,
|
||||
_xdata = Nothing
|
||||
}
|
||||
where
|
||||
-- We should generally show the longer of the path or suffixified name in the label,
|
||||
-- it helps the user understand the difference between options which may otherwise look
|
||||
-- the same.
|
||||
--
|
||||
-- E.g. if I type "ma" then the suffixied options might be: List.map, Bag.map, but the
|
||||
-- path matches are just "map" and "map" since the query starts at that segment, so we
|
||||
-- show the suffixified version to disambiguate.
|
||||
--
|
||||
-- However, if the user types "base.List.ma" then the matching path is "base.List.map" and
|
||||
-- the suffixification is just "List.map", so we use the path in this case because it more
|
||||
-- closely matches what the user actually typed.
|
||||
--
|
||||
-- This is what's felt best to me, anecdotally.
|
||||
lbl =
|
||||
if Text.length path > Text.length suffixified
|
||||
then path
|
||||
else suffixified
|
||||
|
||||
-- | Generate a completion tree from a set of names.
|
||||
-- A completion tree is a suffix tree over the path segments of each name it contains.
|
||||
-- The goal is to allow fast completion of names by any partial path suffix.
|
||||
--
|
||||
-- The tree is generated by building a trie where all possible suffixes of a name are
|
||||
-- reachable from the root of the trie, with sharing over subtrees to improve memory
|
||||
-- residency.
|
||||
--
|
||||
-- Currently we don't "summarize" all of the children of a node in the node itself, and
|
||||
-- instead you have to crawl all the children to get the actual completions.
|
||||
--
|
||||
-- TODO: Would it be worthwhile to perform compression or include child summaries on the suffix tree?
|
||||
-- I suspect most namespace trees won't actually compress very well since each node is likely
|
||||
-- to have terms/types at it.
|
||||
--
|
||||
-- E.g. From the names:
|
||||
-- * alpha.beta.Nat
|
||||
-- * alpha.Text
|
||||
-- * foxtrot.Text
|
||||
--
|
||||
-- It will generate a tree like the following, where each bullet is a possible completion:
|
||||
--
|
||||
-- .
|
||||
-- ├── foxtrot
|
||||
-- │ └── Text
|
||||
-- │ └── * foxtrot.Text (##Text)
|
||||
-- ├── beta
|
||||
-- │ └── Nat
|
||||
-- │ └── * alpha.beta.Nat (##Nat)
|
||||
-- ├── alpha
|
||||
-- │ ├── beta
|
||||
-- │ │ └── Nat
|
||||
-- │ │ └── * alpha.beta.Nat (##Nat)
|
||||
-- │ └── Text
|
||||
-- │ └── * alpha.Text (##Text)
|
||||
-- ├── Text
|
||||
-- │ ├── * foxtrot.Text (##Text)
|
||||
-- │ └── * alpha.Text (##Text)
|
||||
-- └── Nat
|
||||
-- └── * alpha.beta.Nat (##Nat)
|
||||
namesToCompletionTree :: Names -> CompletionTree
|
||||
namesToCompletionTree Names {terms, types} =
|
||||
let typeCompls =
|
||||
Relation.domain types
|
||||
& ifoldMap
|
||||
( \name refs ->
|
||||
refs
|
||||
& Monoid.whenM (not . isDefinitionDoc $ name)
|
||||
& Set.map \ref -> (name, LD.typeRef ref)
|
||||
)
|
||||
termCompls =
|
||||
Relation.domain terms
|
||||
& ifoldMap
|
||||
( \name refs ->
|
||||
refs
|
||||
& Monoid.whenM (not . isDefinitionDoc $ name)
|
||||
& Set.map \ref -> (name, LD.referent ref)
|
||||
)
|
||||
in foldMap (uncurry nameToCompletionTree) (typeCompls <> termCompls)
|
||||
where
|
||||
-- It's annoying to see _all_ the definition docs in autocomplete so we filter them out.
|
||||
-- Special docs like "README" will still appear since they're not named 'doc'
|
||||
isDefinitionDoc name =
|
||||
case Name.reverseSegments name of
|
||||
("doc" :| _) -> True
|
||||
_ -> False
|
||||
|
||||
nameToCompletionTree :: Name -> LabeledDependency -> CompletionTree
|
||||
nameToCompletionTree name ref =
|
||||
let (lastSegment :| prefix) = Name.reverseSegments name
|
||||
complMap = helper (Map.singleton lastSegment (Set.singleton (name, ref) :< mempty)) prefix
|
||||
in CompletionTree (mempty :< complMap)
|
||||
where
|
||||
-- We build the tree bottom-up rather than top-down so we can take 'share' submaps for
|
||||
-- improved memory residency, each call is passed the submap that we built under the
|
||||
-- current reversed path prefix.
|
||||
helper ::
|
||||
Map
|
||||
NameSegment
|
||||
(Cofree (Map NameSegment) (Set (Name, LabeledDependency))) ->
|
||||
[NameSegment] ->
|
||||
Map
|
||||
NameSegment
|
||||
(Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
|
||||
helper subMap revPrefix = case revPrefix of
|
||||
[] -> subMap
|
||||
(ns : rest) ->
|
||||
mergeSubmaps (helper (Map.singleton ns (mempty :< subMap)) rest) subMap
|
||||
where
|
||||
mergeSubmaps = Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b)
|
||||
|
||||
-- | Crawl the completion tree and return all valid prefix-based completions alongside their
|
||||
-- Path from the provided prefix, and their full name.
|
||||
--
|
||||
-- E.g. if the term "alpha.beta.gamma.map (#abc)" exists in the completion map, and the query is "beta" the result would
|
||||
-- be:
|
||||
--
|
||||
-- @@
|
||||
-- [(["beta", "gamma", "map"], "alpha.beta.gamma.map", TermReferent #abc)]
|
||||
-- @@
|
||||
matchCompletions :: CompletionTree -> Text -> [(Path, Name, LabeledDependency)]
|
||||
matchCompletions (CompletionTree tree) txt =
|
||||
matchSegments segments (Set.toList <$> tree)
|
||||
where
|
||||
segments :: [Text]
|
||||
segments =
|
||||
Text.splitOn "." txt
|
||||
& filter (not . Text.null)
|
||||
matchSegments :: [Text] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)]
|
||||
matchSegments xs (currentMatches :< subtreeMap) =
|
||||
case xs of
|
||||
[] ->
|
||||
let current = currentMatches <&> (\(name, def) -> (Path.empty, name, def))
|
||||
in (current <> mkDefMatches subtreeMap)
|
||||
[prefix] ->
|
||||
Map.dropWhileAntitone ((< prefix) . NameSegment.toText) subtreeMap
|
||||
& Map.takeWhileAntitone (Text.isPrefixOf prefix . NameSegment.toText)
|
||||
& \matchingSubtrees ->
|
||||
let subMatches = ifoldMap (\ns subTree -> matchSegments [] subTree & consPathPrefix ns) matchingSubtrees
|
||||
in subMatches
|
||||
(ns : rest) ->
|
||||
foldMap (matchSegments rest) (Map.lookup (NameSegment ns) subtreeMap)
|
||||
& consPathPrefix (NameSegment ns)
|
||||
consPathPrefix :: NameSegment -> ([(Path, Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
consPathPrefix ns = over (mapped . _1) (Path.cons ns)
|
||||
mkDefMatches :: Map NameSegment (Cofree (Map NameSegment) [(Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
mkDefMatches xs = do
|
||||
(ns, (matches :< rest)) <- Map.toList xs
|
||||
let childMatches = mkDefMatches rest <&> over _1 (Path.cons ns)
|
||||
let currentMatches = matches <&> \(name, dep) -> (Path.singleton ns, name, dep)
|
||||
currentMatches <> childMatches
|
||||
|
23
unison-cli/src/Unison/LSP/Configuration.hs
Normal file
23
unison-cli/src/Unison/LSP/Configuration.hs
Normal file
@ -0,0 +1,23 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Unison.LSP.Configuration where
|
||||
|
||||
import Data.Aeson
|
||||
import qualified Data.Text as Text
|
||||
import Language.LSP.Types
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.Types
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Handle configuration changes
|
||||
updateConfig :: Config -> Value -> Either Text Config
|
||||
updateConfig _oldConfig newConfig = Debug.debug Debug.LSP "Configuration Change" $ case fromJSON newConfig of
|
||||
Error err -> Left $ Text.pack err
|
||||
Success a -> Right a
|
||||
|
||||
-- | We could use this notification to cancel/update work-in-progress,
|
||||
-- but we don't actually need to update the config here, that's handled by the lsp library
|
||||
-- automatically.
|
||||
workspaceConfigurationChanged :: NotificationMessage 'WorkspaceDidChangeConfiguration -> Lsp ()
|
||||
workspaceConfigurationChanged _m = do
|
||||
pure ()
|
@ -33,7 +33,7 @@ reportDiagnostics ::
|
||||
f Diagnostic ->
|
||||
Lsp ()
|
||||
reportDiagnostics docUri fileVersion diags = do
|
||||
let jsonRPC = "" -- TODO: what's this for?
|
||||
let jsonRPC = "2.0"
|
||||
let params = PublishDiagnosticsParams {_uri = docUri, _version = fromIntegral <$> fileVersion, _diagnostics = List . toList $ diags}
|
||||
sendNotification (NotificationMessage jsonRPC STextDocumentPublishDiagnostics params)
|
||||
|
||||
|
@ -1,19 +1,28 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Unison.LSP.Types where
|
||||
|
||||
import Colog.Core hiding (Lens')
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Comonad.Cofree (Cofree)
|
||||
import qualified Control.Comonad.Cofree as Cofree
|
||||
import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSC
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.IntervalMap.Lazy (IntervalMap)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Ki
|
||||
import qualified Language.LSP.Logging as LSP
|
||||
import Language.LSP.Server
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.Types
|
||||
import Language.LSP.Types.Lens
|
||||
import Language.LSP.VFS
|
||||
@ -21,6 +30,9 @@ import Unison.Codebase
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NamesWithHistory (NamesWithHistory)
|
||||
import Unison.Parser.Ann
|
||||
import Unison.Prelude
|
||||
@ -65,9 +77,25 @@ data Env = Env
|
||||
dirtyFilesVar :: TVar (Set Uri),
|
||||
-- A map of request IDs to an action which kills that request.
|
||||
cancellationMapVar :: TVar (Map SomeLspId (IO ())),
|
||||
-- A lazily computed map of all valid completion suffixes from the current path.
|
||||
completionsVar :: TVar CompletionTree,
|
||||
scope :: Ki.Scope
|
||||
}
|
||||
|
||||
-- | A suffix tree over path segments of name completions.
|
||||
-- see 'namesToCompletionTree' for more on how this is built and the invariants it should have.
|
||||
newtype CompletionTree = CompletionTree
|
||||
{ unCompletionTree :: Cofree (Map NameSegment) (Set (Name, LabeledDependency))
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Semigroup CompletionTree where
|
||||
CompletionTree (a Cofree.:< subtreeA) <> CompletionTree (b Cofree.:< subtreeB) =
|
||||
CompletionTree (a <> b Cofree.:< Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b) subtreeA subtreeB)
|
||||
|
||||
instance Monoid CompletionTree where
|
||||
mempty = CompletionTree $ mempty Cofree.:< mempty
|
||||
|
||||
-- | A monotonically increasing file version tracked by the lsp client.
|
||||
type FileVersion = Int32
|
||||
|
||||
@ -88,6 +116,9 @@ data FileAnalysis = FileAnalysis
|
||||
getCurrentPath :: Lsp Path.Absolute
|
||||
getCurrentPath = asks currentPathCache >>= liftIO
|
||||
|
||||
getCompletions :: Lsp CompletionTree
|
||||
getCompletions = asks completionsVar >>= readTVarIO
|
||||
|
||||
globalPPE :: Lsp PrettyPrintEnvDecl
|
||||
globalPPE = asks ppeCache >>= liftIO
|
||||
|
||||
@ -95,6 +126,41 @@ getParseNames :: Lsp NamesWithHistory
|
||||
getParseNames = asks parseNamesCache >>= liftIO
|
||||
|
||||
data Config = Config
|
||||
{ -- 'Nothing' will load ALL available completions, which is slower, but may provide a better
|
||||
-- solution for some users.
|
||||
--
|
||||
-- 'Just n' will only fetch the first 'n' completions and will prompt the client to ask for
|
||||
-- more completions after more typing.
|
||||
maxCompletions :: Maybe Int
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
instance Aeson.FromJSON Config where
|
||||
parseJSON = Aeson.withObject "Config" \obj -> do
|
||||
maxCompletions <- obj Aeson..:! "maxCompletions" Aeson..!= maxCompletions defaultLSPConfig
|
||||
let invalidKeys = Set.fromList (HM.keys obj) `Set.difference` validKeys
|
||||
when (not . null $ invalidKeys) do
|
||||
fail . Text.unpack $
|
||||
"Unrecognized configuration key(s): "
|
||||
<> Text.intercalate ", " (Set.toList invalidKeys)
|
||||
<> ".\nThe default configuration is:\n"
|
||||
<> Text.pack defaultConfigExample
|
||||
pure Config {..}
|
||||
where
|
||||
validKeys = Set.fromList ["maxCompletions"]
|
||||
defaultConfigExample =
|
||||
BSC.unpack $ Aeson.encode defaultLSPConfig
|
||||
|
||||
instance Aeson.ToJSON Config where
|
||||
toJSON (Config maxCompletions) =
|
||||
Aeson.object
|
||||
[ "maxCompletions" Aeson..= maxCompletions
|
||||
]
|
||||
|
||||
defaultLSPConfig :: Config
|
||||
defaultLSPConfig = Config {..}
|
||||
where
|
||||
maxCompletions = Just 100
|
||||
|
||||
-- | Lift a backend computation into the Lsp monad.
|
||||
lspBackend :: Backend.Backend IO a -> Lsp (Either Backend.BackendError a)
|
||||
@ -142,3 +208,9 @@ includeEdits uri replacement ranges rca =
|
||||
_changeAnnotations = Nothing
|
||||
}
|
||||
in rca & codeAction . edit ?~ workspaceEdit
|
||||
|
||||
getConfig :: Lsp Config
|
||||
getConfig = LSP.getConfig
|
||||
|
||||
setConfig :: Config -> Lsp ()
|
||||
setConfig = LSP.setConfig
|
||||
|
@ -5,9 +5,11 @@ import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.Completion
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import Unison.NamesWithHistory (NamesWithHistory)
|
||||
import qualified Unison.NamesWithHistory as NamesWithHistory
|
||||
import Unison.PrettyPrintEnvDecl
|
||||
import qualified Unison.PrettyPrintEnvDecl.Names as PPE
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
@ -21,7 +23,7 @@ ucmWorker ::
|
||||
STM Path.Absolute ->
|
||||
Lsp ()
|
||||
ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
|
||||
Env {codebase} <- ask
|
||||
Env {codebase, completionsVar} <- ask
|
||||
let loop :: (Branch IO, Path.Absolute) -> Lsp a
|
||||
loop (currentRoot, currentPath) = do
|
||||
Debug.debugM Debug.LSP "LSP path: " currentPath
|
||||
@ -33,6 +35,8 @@ ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
|
||||
writeTVar ppeVar ppe
|
||||
-- Re-check everything with the new names and ppe
|
||||
VFS.markAllFilesDirty
|
||||
atomically do
|
||||
writeTVar completionsVar (namesToCompletionTree $ NamesWithHistory.currentNames parseNames)
|
||||
latest <- atomically $ do
|
||||
latestRoot <- getLatestRoot
|
||||
latestPath <- getLatestPath
|
||||
|
@ -72,6 +72,7 @@ library
|
||||
Unison.LSP.CancelRequest
|
||||
Unison.LSP.CodeAction
|
||||
Unison.LSP.Completion
|
||||
Unison.LSP.Configuration
|
||||
Unison.LSP.Conversions
|
||||
Unison.LSP.Diagnostics
|
||||
Unison.LSP.FileAnalysis
|
||||
@ -140,6 +141,7 @@ library
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -261,6 +263,7 @@ executable cli-integration-tests
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -377,6 +380,7 @@ executable transcripts
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -497,6 +501,7 @@ executable unison
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -624,6 +629,7 @@ test-suite cli-tests
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
|
Loading…
Reference in New Issue
Block a user