dhall-lsp-server: Implement completion support (#1190)
* Implement completion support Completes the following: - environment variables - local imports - identifiers in scope (as well as built-ins) - record projections - union constructors * Add support for general dependent types Removes the non-dependent let path. Needed since #1164 added support for general dependent types. * Remove unused import * Use monad instance to cast between `Expr Src _` As suggested by @Gabriel439: Use `typeOf (do _ <- expr; holeExpr)` instead of `fmap undefined expr`. In the absence of `Embed` constructors (in this case `Import`s) the two are equivalent. * Simplify completeFromContext Caught by @Gabriel439 * Remove debug code * Add 1s timeout to listDirectory call As pointed out by @Gabriel439, listDirectory can be a potentially expensive operation. Adding a timeout should improve the user experience. * Fix unclean merge
This commit is contained in:
parent
523861a92c
commit
5f3b05a8f2
|
@ -20,6 +20,7 @@ source-repository head
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
|
Dhall.LSP.Backend.Completion
|
||||||
Dhall.LSP.Backend.Dhall
|
Dhall.LSP.Backend.Dhall
|
||||||
Dhall.LSP.Backend.Diagnostics
|
Dhall.LSP.Backend.Diagnostics
|
||||||
Dhall.LSP.Backend.Freezing
|
Dhall.LSP.Backend.Freezing
|
||||||
|
@ -44,6 +45,7 @@ library
|
||||||
, bytestring >= 0.10.8.2 && < 0.11
|
, bytestring >= 0.10.8.2 && < 0.11
|
||||||
, containers >= 0.5.11.0 && < 0.7
|
, containers >= 0.5.11.0 && < 0.7
|
||||||
, data-default >= 0.7.1.1 && < 0.8
|
, data-default >= 0.7.1.1 && < 0.8
|
||||||
|
, directory >= 1.2.2.0 && < 1.4
|
||||||
, dhall >= 1.25.0 && < 1.26
|
, dhall >= 1.25.0 && < 1.26
|
||||||
, dhall-json >= 1.4 && < 1.5
|
, dhall-json >= 1.4 && < 1.5
|
||||||
, filepath >= 1.4.2 && < 1.5
|
, filepath >= 1.4.2 && < 1.5
|
||||||
|
|
182
dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs
Normal file
182
dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs
Normal file
|
@ -0,0 +1,182 @@
|
||||||
|
module Dhall.LSP.Backend.Completion where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Void (absurd)
|
||||||
|
import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset)
|
||||||
|
import System.Directory (doesDirectoryExist, listDirectory)
|
||||||
|
import System.FilePath (takeDirectory, (</>))
|
||||||
|
import System.Environment (getEnvironment)
|
||||||
|
import System.Timeout (timeout)
|
||||||
|
|
||||||
|
import Dhall.Context (empty, toList)
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import Dhall.Context (Context, insert)
|
||||||
|
import Dhall.Core (Expr(..), Binding(..), Var(..), normalize, shift, subst, pretty, reservedIdentifiers)
|
||||||
|
import Dhall.TypeCheck (X, typeWithA, typeOf)
|
||||||
|
import Dhall.Parser (Src, exprFromText)
|
||||||
|
import qualified Dhall.Map
|
||||||
|
import qualified Data.HashSet as HashSet
|
||||||
|
|
||||||
|
import Dhall.LSP.Backend.Parsing (holeExpr)
|
||||||
|
|
||||||
|
-- | Given the cursor position construct the corresponding 'completion query'
|
||||||
|
-- consisting of the leadup, i.e. text leading up to the word prefix that is to
|
||||||
|
-- be completed, as well as the prefix that is to be completed.
|
||||||
|
completionQueryAt :: Text -> Position -> (Text, Text)
|
||||||
|
completionQueryAt text pos = (completionLeadup, completionPrefix)
|
||||||
|
where
|
||||||
|
off = positionToOffset text pos
|
||||||
|
text' = Text.take off text
|
||||||
|
breakEnd :: (Char -> Bool) -> Text -> (Text, Text)
|
||||||
|
breakEnd p =
|
||||||
|
(\(l,r) -> (Text.reverse l, Text.reverse r)) . Text.break p . Text.reverse
|
||||||
|
(completionPrefix, completionLeadup) =
|
||||||
|
breakEnd (`elem` (" \t\n[(,=+*&|}#?>" :: [Char])) text'
|
||||||
|
|
||||||
|
-- | A completion result, optionally annotated with type information.
|
||||||
|
data Completion =
|
||||||
|
Completion {
|
||||||
|
completeText :: Text,
|
||||||
|
completeType :: Maybe (Expr Src X) }
|
||||||
|
|
||||||
|
-- | Complete file names.
|
||||||
|
completeLocalImport :: FilePath -> FilePath -> IO [Completion]
|
||||||
|
completeLocalImport relativeTo prefix = do
|
||||||
|
let dir = takeDirectory relativeTo </> takeDirectory prefix
|
||||||
|
exists <- doesDirectoryExist dir
|
||||||
|
if not exists
|
||||||
|
then return []
|
||||||
|
else do
|
||||||
|
let second = 10 ^ (6 :: Int)
|
||||||
|
mFiles <- timeout second (listDirectory dir) -- 1s timeout
|
||||||
|
case mFiles of
|
||||||
|
Just files -> return (map (\file -> Completion (Text.pack file) Nothing) files)
|
||||||
|
Nothing -> return []
|
||||||
|
|
||||||
|
-- | Complete environment variables.
|
||||||
|
completeEnvironmentImport :: IO [Completion]
|
||||||
|
completeEnvironmentImport = do
|
||||||
|
environment <- getEnvironment
|
||||||
|
let environmentImports = map (Text.pack . fst) environment
|
||||||
|
return $ map (\env -> Completion env Nothing) environmentImports
|
||||||
|
|
||||||
|
|
||||||
|
-- | A completion context, consisting of the (approximated) type-checking
|
||||||
|
-- context. We need to substitute 'dependent lets' later so we keep their values
|
||||||
|
-- around.
|
||||||
|
data CompletionContext =
|
||||||
|
CompletionContext {
|
||||||
|
context :: Context (Expr Src X),
|
||||||
|
-- values to be substituted for 'dependent let' behaviour
|
||||||
|
values :: Context (Expr Src X) }
|
||||||
|
|
||||||
|
-- | Given a 'binders expression' (with arbitrarily many 'holes') construct the
|
||||||
|
-- corresponding completion context.
|
||||||
|
buildCompletionContext :: Expr Src X -> CompletionContext
|
||||||
|
buildCompletionContext = buildCompletionContext' empty empty
|
||||||
|
|
||||||
|
buildCompletionContext' :: Context (Expr Src X) -> Context (Expr Src X)
|
||||||
|
-> Expr Src X -> CompletionContext
|
||||||
|
buildCompletionContext' context values (Let (Binding x mA a :| []) e)
|
||||||
|
-- We prefer the actual value over the annotated type in order to get
|
||||||
|
-- 'dependent let' behaviour whenever possible.
|
||||||
|
| Right _A <- typeWithA absurd context a =
|
||||||
|
let _A' = normalize _A
|
||||||
|
|
||||||
|
a' = normalize a
|
||||||
|
e' = subst (V x 0) a' e
|
||||||
|
|
||||||
|
context' = fmap (shift 1 (V x 0)) $ insert x _A' context
|
||||||
|
values' = fmap (shift 1 (V x 0)) $ insert x a' values
|
||||||
|
|
||||||
|
in buildCompletionContext' context' values' e'
|
||||||
|
|
||||||
|
-- fall back to annotated type if body doesn't type check; bind to `holeExpr`
|
||||||
|
| Just _A <- mA
|
||||||
|
, Right _ <- typeWithA absurd context _A =
|
||||||
|
let _A' = normalize _A
|
||||||
|
|
||||||
|
context' = fmap (shift 1 (V x 0)) $ insert x _A' context
|
||||||
|
values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
|
||||||
|
|
||||||
|
in buildCompletionContext' context' values' e
|
||||||
|
|
||||||
|
-- if nothing works, only remember the name (but bind to `holeExpr`)
|
||||||
|
| otherwise =
|
||||||
|
let context' = fmap (shift 1 (V x 0)) $ insert x holeExpr context
|
||||||
|
values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
|
||||||
|
|
||||||
|
in buildCompletionContext' context' values' e
|
||||||
|
|
||||||
|
buildCompletionContext' context values (Lam x _A b) =
|
||||||
|
let _A' | Right _ <- typeWithA absurd context _A = normalize _A
|
||||||
|
| otherwise = holeExpr
|
||||||
|
|
||||||
|
context' = fmap (shift 1 (V x 0)) $ insert x _A' context
|
||||||
|
values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
|
||||||
|
|
||||||
|
in buildCompletionContext' context' values' b
|
||||||
|
|
||||||
|
buildCompletionContext' context values (Pi x _A b) =
|
||||||
|
let _A' | Right _ <- typeWithA absurd context _A = normalize _A
|
||||||
|
| otherwise = holeExpr
|
||||||
|
|
||||||
|
context' = fmap (shift 1 (V x 0)) $ insert x _A' context
|
||||||
|
values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
|
||||||
|
|
||||||
|
in buildCompletionContext' context' values' b
|
||||||
|
|
||||||
|
-- catch-all
|
||||||
|
buildCompletionContext' context values _ = CompletionContext context values
|
||||||
|
|
||||||
|
-- Helper. Given `Dhall.Context.toList ctx` construct the corresponding variable
|
||||||
|
-- names.
|
||||||
|
contextToVariables :: [(Text, Expr Src X)] -> [Var]
|
||||||
|
contextToVariables [] = []
|
||||||
|
contextToVariables ((name, _) : rest) =
|
||||||
|
V name 0 : map (inc name) (contextToVariables rest)
|
||||||
|
where inc x (V y i) | x == y = V x (i + 1)
|
||||||
|
| otherwise = V y i
|
||||||
|
|
||||||
|
-- | Complete identifiers from the given completion context.
|
||||||
|
completeFromContext :: CompletionContext -> [Completion]
|
||||||
|
completeFromContext (CompletionContext context _) =
|
||||||
|
let context' = toList context
|
||||||
|
completeReserved keyword
|
||||||
|
| Right expr <- exprFromText "" keyword
|
||||||
|
, Right typ <- typeOf (do _ <- expr; holeExpr) =
|
||||||
|
Completion keyword (Just typ)
|
||||||
|
| otherwise = Completion keyword Nothing
|
||||||
|
reserved = map completeReserved $ HashSet.toList reservedIdentifiers
|
||||||
|
in [ Completion (pretty var) (if typ == holeExpr then Nothing else Just typ)
|
||||||
|
| (var, (_, typ)) <- zip (contextToVariables context') context' ]
|
||||||
|
++ reserved
|
||||||
|
|
||||||
|
-- | Complete union constructors and record projections.
|
||||||
|
completeProjections :: CompletionContext -> Expr Src X -> [Completion]
|
||||||
|
completeProjections (CompletionContext context values) expr =
|
||||||
|
-- substitute 'dependent lets', necessary for completion of unions
|
||||||
|
let values' = toList values
|
||||||
|
subs = filter ((/= holeExpr) . snd) $ zip (contextToVariables values') (map snd values')
|
||||||
|
expr' = foldl (\e (x,val) -> subst x val e) expr subs
|
||||||
|
|
||||||
|
in case typeWithA absurd context expr' of
|
||||||
|
Left _ -> []
|
||||||
|
Right _A ->
|
||||||
|
let expr'' = normalize expr'
|
||||||
|
in completeUnion expr'' expr'' ++ completeRecord (normalize _A)
|
||||||
|
|
||||||
|
where
|
||||||
|
-- complete a union constructor by inspecting the union value
|
||||||
|
completeUnion _A (Union m) =
|
||||||
|
let constructor (k, Nothing) = Completion k (Just _A)
|
||||||
|
constructor (k, Just v) = Completion k (Just (Pi k v _A))
|
||||||
|
in map constructor (Dhall.Map.toList m)
|
||||||
|
completeUnion _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
-- complete a record projection by inspecting the record type
|
||||||
|
completeRecord (Record m) =
|
||||||
|
map (\(name, typ) -> Completion name (Just typ)) (Dhall.Map.toList m)
|
||||||
|
completeRecord _ = []
|
|
@ -4,13 +4,21 @@ module Dhall.LSP.Backend.Parsing
|
||||||
, getLetAnnot
|
, getLetAnnot
|
||||||
, getLetIdentifier
|
, getLetIdentifier
|
||||||
, getLamIdentifier
|
, getLamIdentifier
|
||||||
, getForallIdentifier)
|
, getForallIdentifier
|
||||||
|
, binderExprFromText
|
||||||
|
, holeExpr
|
||||||
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Dhall.Core (Expr(..), Import, Binding(..), Var(..))
|
||||||
import Dhall.Src (Src(..))
|
import Dhall.Src (Src(..))
|
||||||
import Dhall.Parser
|
import Dhall.Parser
|
||||||
import Dhall.Parser.Token
|
import Dhall.Parser.Token
|
||||||
import Dhall.Parser.Expression
|
import Dhall.Parser.Expression
|
||||||
|
import Text.Megaparsec ((<|>), try, skipManyTill, lookAhead, anySingle,
|
||||||
|
notFollowedBy, eof, takeRest)
|
||||||
|
|
||||||
import Control.Applicative (optional)
|
import Control.Applicative (optional)
|
||||||
import qualified Text.Megaparsec as Megaparsec
|
import qualified Text.Megaparsec as Megaparsec
|
||||||
|
@ -122,3 +130,112 @@ setSourcePos :: SourcePos -> Parser ()
|
||||||
setSourcePos src = Megaparsec.updateParserState
|
setSourcePos src = Megaparsec.updateParserState
|
||||||
(\(Megaparsec.State s o (Megaparsec.PosState i o' _ t l)) ->
|
(\(Megaparsec.State s o (Megaparsec.PosState i o' _ t l)) ->
|
||||||
Megaparsec.State s o (Megaparsec.PosState i o' src t l))
|
Megaparsec.State s o (Megaparsec.PosState i o' src t l))
|
||||||
|
|
||||||
|
|
||||||
|
-- | An expression that is guaranteed not to typecheck. Can be used a
|
||||||
|
-- placeholder type to emulate 'lazy' contexts, when typechecking something in a
|
||||||
|
-- only partly well-typed context.
|
||||||
|
holeExpr :: Expr s a
|
||||||
|
-- The illegal variable name ensures that it can't be bound by the user!
|
||||||
|
holeExpr = Var (V "" 0)
|
||||||
|
|
||||||
|
-- | Approximate the type-checking context at the end of the input. Tries to
|
||||||
|
-- parse as many binders as possible. Very messy!
|
||||||
|
binderExprFromText :: Text -> Expr Src Import
|
||||||
|
binderExprFromText txt =
|
||||||
|
case Megaparsec.parseMaybe (unParser parseBinderExpr) (txt <> " ") of
|
||||||
|
Just e -> e
|
||||||
|
Nothing -> holeExpr
|
||||||
|
where
|
||||||
|
-- marks the beginning of the next binder
|
||||||
|
boundary = _let <|> _forall <|> _lambda
|
||||||
|
|
||||||
|
-- A binder that is out of scope at the end of the input. Discarded in the
|
||||||
|
-- resulting 'binder expression'.
|
||||||
|
closedBinder = closedLet <|> closedLambda <|> closedPi
|
||||||
|
|
||||||
|
closedLet = do
|
||||||
|
_let
|
||||||
|
_ <- label
|
||||||
|
_ <- optional (do
|
||||||
|
_colon
|
||||||
|
expr)
|
||||||
|
_equal
|
||||||
|
_ <- expr
|
||||||
|
(do
|
||||||
|
_in
|
||||||
|
_ <- expr
|
||||||
|
return ())
|
||||||
|
<|> closedLet
|
||||||
|
|
||||||
|
closedLambda = do
|
||||||
|
_lambda
|
||||||
|
_openParens
|
||||||
|
_ <- label
|
||||||
|
_colon
|
||||||
|
_ <- expr
|
||||||
|
_closeParens
|
||||||
|
_arrow
|
||||||
|
_ <- expr
|
||||||
|
return ()
|
||||||
|
|
||||||
|
closedPi = do
|
||||||
|
_forall
|
||||||
|
_openParens
|
||||||
|
_ <- label
|
||||||
|
_colon
|
||||||
|
_ <- expr
|
||||||
|
_closeParens
|
||||||
|
_arrow
|
||||||
|
_ <- expr
|
||||||
|
return ()
|
||||||
|
|
||||||
|
-- Try to parse as many binders as possible. Skip malformed input and
|
||||||
|
-- 'closed' binders that are already out of scope at the end of the input.
|
||||||
|
parseBinderExpr = do
|
||||||
|
try (do
|
||||||
|
skipManyTill anySingle (lookAhead boundary)
|
||||||
|
try (do
|
||||||
|
closedBinder
|
||||||
|
notFollowedBy eof
|
||||||
|
parseBinderExpr)
|
||||||
|
<|> try (letBinder <|> lambdaBinder <|> forallBinder)
|
||||||
|
<|> (do
|
||||||
|
boundary
|
||||||
|
parseBinderExpr))
|
||||||
|
<|> (do
|
||||||
|
_ <- takeRest
|
||||||
|
return holeExpr)
|
||||||
|
|
||||||
|
letBinder = do
|
||||||
|
_let
|
||||||
|
name <- label
|
||||||
|
mType <- optional (do _colon; expr)
|
||||||
|
|
||||||
|
-- if the bound value does not parse, skip and replace with 'hole'
|
||||||
|
value <- try (do _equal; expr)
|
||||||
|
<|> (do skipManyTill anySingle (lookAhead boundary <|> _in); return holeExpr)
|
||||||
|
inner <- parseBinderExpr
|
||||||
|
return (Let (Binding name mType value :| []) inner)
|
||||||
|
|
||||||
|
forallBinder = do
|
||||||
|
_forall
|
||||||
|
_openParens
|
||||||
|
name <- label
|
||||||
|
_colon
|
||||||
|
-- if the bound type does not parse, skip and replace with 'hole'
|
||||||
|
typ <- try (do e <- expr; _closeParens; _arrow; return e)
|
||||||
|
<|> (do skipManyTill anySingle _arrow; return holeExpr)
|
||||||
|
inner <- parseBinderExpr
|
||||||
|
return (Pi name typ inner)
|
||||||
|
|
||||||
|
lambdaBinder = do
|
||||||
|
_lambda
|
||||||
|
_openParens
|
||||||
|
name <- label
|
||||||
|
_colon
|
||||||
|
-- if the bound type does not parse, skip and replace with 'hole'
|
||||||
|
typ <- try (do e <- expr; _closeParens; _arrow; return e)
|
||||||
|
<|> (do skipManyTill anySingle _arrow; return holeExpr)
|
||||||
|
inner <- parseBinderExpr
|
||||||
|
return (Lam name typ inner)
|
||||||
|
|
|
@ -2,7 +2,7 @@ module Dhall.LSP.Backend.Typing (annotateLet, exprAt, srcAt, typeAt) where
|
||||||
|
|
||||||
import Dhall.Context (Context, insert, empty)
|
import Dhall.Context (Context, insert, empty)
|
||||||
import Dhall.Core (Expr(..), Binding(..), Const(..), subExpressions, normalize, shift, subst, Var(..))
|
import Dhall.Core (Expr(..), Binding(..), Const(..), subExpressions, normalize, shift, subst, Var(..))
|
||||||
import Dhall.TypeCheck (typeWithA, X(..), TypeError(..))
|
import Dhall.TypeCheck (typeWithA, X, TypeError(..))
|
||||||
import Dhall.Parser (Src(..))
|
import Dhall.Parser (Src(..))
|
||||||
|
|
||||||
import Data.List.NonEmpty (NonEmpty (..))
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
|
|
@ -13,6 +13,8 @@ import Dhall.Import (localToPath)
|
||||||
import Dhall.Parser (Src(..))
|
import Dhall.Parser (Src(..))
|
||||||
import Dhall.TypeCheck (X)
|
import Dhall.TypeCheck (X)
|
||||||
|
|
||||||
|
import Dhall.LSP.Backend.Completion (Completion(..), completionQueryAt,
|
||||||
|
completeEnvironmentImport, completeLocalImport, buildCompletionContext, completeProjections, completeFromContext)
|
||||||
import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
|
import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
|
||||||
fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader)
|
fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader)
|
||||||
import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
|
import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
|
||||||
|
@ -21,6 +23,7 @@ import Dhall.LSP.Backend.Formatting (formatExprWithHeader)
|
||||||
import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition,
|
import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition,
|
||||||
stripHash, getAllImportsWithHashPositions)
|
stripHash, getAllImportsWithHashPositions)
|
||||||
import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
|
import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
|
||||||
|
import Dhall.LSP.Backend.Parsing (binderExprFromText)
|
||||||
import Dhall.LSP.Backend.Typing (typeAt, annotateLet, exprAt)
|
import Dhall.LSP.Backend.Typing (typeAt, annotateLet, exprAt)
|
||||||
import Dhall.LSP.State
|
import Dhall.LSP.State
|
||||||
|
|
||||||
|
@ -34,14 +37,13 @@ import Control.Monad.Trans.State.Strict (execStateT)
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.Maybe (maybeToList)
|
import Data.Maybe (maybeToList)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text, isPrefixOf)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Network.URI as URI
|
import qualified Network.URI as URI
|
||||||
import qualified Network.URI.Encode as URI
|
import qualified Network.URI.Encode as URI
|
||||||
import Text.Megaparsec (SourcePos(..), unPos)
|
import Text.Megaparsec (SourcePos(..), unPos)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
|
|
||||||
-- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
|
-- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
|
||||||
-- expects a multi-threaded implementation. Reports errors to the user via the
|
-- expects a multi-threaded implementation. Reports errors to the user via the
|
||||||
-- LSP `ShowMessage` notification.
|
-- LSP `ShowMessage` notification.
|
||||||
|
@ -430,6 +432,93 @@ executeFreezeImport request = do
|
||||||
lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit
|
lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit
|
||||||
(J.ApplyWorkspaceEditParams edit)
|
(J.ApplyWorkspaceEditParams edit)
|
||||||
|
|
||||||
|
completionHandler :: J.CompletionRequest -> HandlerM ()
|
||||||
|
completionHandler request = do
|
||||||
|
let uri = request ^. J.params . J.textDocument . J.uri
|
||||||
|
line = request ^. J.params . J.position . J.line
|
||||||
|
col = request ^. J.params . J.position . J.character
|
||||||
|
|
||||||
|
txt <- readUri uri
|
||||||
|
let (completionLeadup, completionPrefix) = completionQueryAt txt (line, col)
|
||||||
|
|
||||||
|
let computeCompletions
|
||||||
|
-- environment variable
|
||||||
|
| "env:" `isPrefixOf` completionPrefix =
|
||||||
|
liftIO $ completeEnvironmentImport
|
||||||
|
|
||||||
|
-- local import
|
||||||
|
| any (`isPrefixOf` completionPrefix) [ "/", "./", "../", "~/" ] = do
|
||||||
|
let relativeTo | Just path <- J.uriToFilePath uri = path
|
||||||
|
| otherwise = "."
|
||||||
|
liftIO $ completeLocalImport relativeTo (Text.unpack completionPrefix)
|
||||||
|
|
||||||
|
-- record projection / union constructor
|
||||||
|
| (target, _) <- Text.breakOnEnd "." completionPrefix
|
||||||
|
, not (Text.null target) = do
|
||||||
|
let bindersExpr = binderExprFromText completionLeadup
|
||||||
|
|
||||||
|
fileIdentifier <- fileIdentifierFromUri uri
|
||||||
|
cache <- use importCache
|
||||||
|
loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache
|
||||||
|
|
||||||
|
(cache', bindersExpr') <-
|
||||||
|
case loadedBinders of
|
||||||
|
Right (cache', binders) -> do
|
||||||
|
return (cache', binders)
|
||||||
|
Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")
|
||||||
|
|
||||||
|
let completionContext = buildCompletionContext bindersExpr'
|
||||||
|
|
||||||
|
targetExpr <- case parse (Text.dropEnd 1 target) of
|
||||||
|
Right e -> return e
|
||||||
|
Left _ -> throwE (Log, "Could not complete projection; prefix did not parse.")
|
||||||
|
|
||||||
|
loaded' <- liftIO $ load fileIdentifier targetExpr cache'
|
||||||
|
case loaded' of
|
||||||
|
Right (cache'', targetExpr') -> do
|
||||||
|
assign importCache cache''
|
||||||
|
return (completeProjections completionContext targetExpr')
|
||||||
|
Left _ -> return []
|
||||||
|
|
||||||
|
-- complete identifiers in scope
|
||||||
|
| otherwise = do
|
||||||
|
let bindersExpr = binderExprFromText completionLeadup
|
||||||
|
|
||||||
|
fileIdentifier <- fileIdentifierFromUri uri
|
||||||
|
cache <- use importCache -- todo save cache afterwards
|
||||||
|
loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache
|
||||||
|
|
||||||
|
bindersExpr' <-
|
||||||
|
case loadedBinders of
|
||||||
|
Right (cache', binders) -> do
|
||||||
|
assign importCache cache'
|
||||||
|
return binders
|
||||||
|
Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")
|
||||||
|
|
||||||
|
let context = buildCompletionContext bindersExpr'
|
||||||
|
return (completeFromContext context)
|
||||||
|
|
||||||
|
completions <- computeCompletions
|
||||||
|
|
||||||
|
let item (Completion {..}) = J.CompletionItem {..}
|
||||||
|
where
|
||||||
|
_label = completeText
|
||||||
|
_kind = Nothing
|
||||||
|
_detail = fmap pretty completeType
|
||||||
|
_documentation = Nothing
|
||||||
|
_deprecated = Nothing
|
||||||
|
_preselect = Nothing
|
||||||
|
_sortText = Nothing
|
||||||
|
_filterText = Nothing
|
||||||
|
_insertText = Nothing
|
||||||
|
_insertTextFormat = Nothing
|
||||||
|
_textEdit = Nothing
|
||||||
|
_additionalTextEdits = Nothing
|
||||||
|
_commitCharacters = Nothing
|
||||||
|
_command = Nothing
|
||||||
|
_xdata = Nothing
|
||||||
|
lspRespond LSP.RspCompletion request $ J.Completions (J.List (map item completions))
|
||||||
|
|
||||||
|
|
||||||
-- handler that doesn't do anything. Useful for example to make haskell-lsp shut
|
-- handler that doesn't do anything. Useful for example to make haskell-lsp shut
|
||||||
-- up about unhandled DidChangeTextDocument notifications (which are already
|
-- up about unhandled DidChangeTextDocument notifications (which are already
|
||||||
|
|
|
@ -14,7 +14,8 @@ import qualified System.Log.Logger
|
||||||
import Dhall.LSP.State
|
import Dhall.LSP.State
|
||||||
import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler,
|
import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler,
|
||||||
didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler,
|
didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler,
|
||||||
executeCommandHandler, documentFormattingHandler, documentLinkHandler)
|
executeCommandHandler, documentFormattingHandler, documentLinkHandler,
|
||||||
|
completionHandler)
|
||||||
|
|
||||||
-- | The main entry point for the LSP server.
|
-- | The main entry point for the LSP server.
|
||||||
run :: Maybe FilePath -> IO ()
|
run :: Maybe FilePath -> IO ()
|
||||||
|
@ -65,6 +66,10 @@ syncOptions = J.TextDocumentSyncOptions
|
||||||
-- Server capabilities. Tells the LSP client that we can execute commands etc.
|
-- Server capabilities. Tells the LSP client that we can execute commands etc.
|
||||||
lspOptions :: LSP.Core.Options
|
lspOptions :: LSP.Core.Options
|
||||||
lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
||||||
|
, LSP.Core.completionProvider =
|
||||||
|
Just (J.CompletionOptions {
|
||||||
|
_resolveProvider = Nothing
|
||||||
|
, _triggerCharacters = Just [":", ".", "/"] })
|
||||||
, LSP.Core.executeCommandProvider =
|
, LSP.Core.executeCommandProvider =
|
||||||
-- Note that this registers the dhall.server.lint command
|
-- Note that this registers the dhall.server.lint command
|
||||||
-- with VSCode, which means that our plugin can't expose a
|
-- with VSCode, which means that our plugin can't expose a
|
||||||
|
@ -93,4 +98,5 @@ lspHandlers state
|
||||||
, LSP.Core.executeCommandHandler = Just $ wrapHandler state executeCommandHandler
|
, LSP.Core.executeCommandHandler = Just $ wrapHandler state executeCommandHandler
|
||||||
, LSP.Core.documentFormattingHandler = Just $ wrapHandler state documentFormattingHandler
|
, LSP.Core.documentFormattingHandler = Just $ wrapHandler state documentFormattingHandler
|
||||||
, LSP.Core.documentLinkHandler = Just $ wrapHandler state documentLinkHandler
|
, LSP.Core.documentLinkHandler = Just $ wrapHandler state documentLinkHandler
|
||||||
|
, LSP.Core.completionHandler = Just $ wrapHandler state completionHandler
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in New Issue
Block a user