dhall-lsp-server: Implement caching (#1040)
* Rewriting Dhall.LSP.Backend.Dhall: Implement new API The old "backend" consisted of a random collection of ways to invoke Dhall: - runDhall :: FilePath -> Text -> IO (Expr Src X) - runDhallSafe :: FilePath -> Text -> IO (Maybe (Expr Src X)) - loadDhallExprSafe :: FilePath -> Text -> IO (Maybe (Expr Src X)) The new backend exposes a slightly more though-out API. This also lays the foundation for performance improvements in the dhall lsp server via caching. * Reorder code in Dhall.LSP.Backend.Dhall * Remove unused constructor * Rewrite and document Backend.Formatting * Refactor Dhall.LSP.Backend.Linting * Refactor Dhall.LSP.Backend.ToJSON * Adapt Diagnostics backend to the new Dhall API * Remove old Dhall backend API * Implement caching; revamp LSP frontend This commit implements caching of Dhall expressions: we only need to fetch, typecheck and normalise each import once per session, unless they change! This means that `dhall-lsp-server` is now viable for non-trivial Dhall projects, for example probing around in `dhall-nethack` everything feels near-instantaneous once the imports have been resolved. This implementation currently has a bug: we don't invalidate imports transitively, i.e. if A.dhall loads B.dhall and B.dhall changes we do not discard the cached version of A.dhall. This should be reasonably easy to fix given some time with Dhall's import graph. Furthermore, there is some cleaning up left to do: - Fix warnings - Reorganise things in a less ad-hoc way - Make the code a bit prettier * Fix caching of errors * Use `bimap` instead of `first` and `second` * Re-export `Dhall.lint` rather than aliasing Rids us of some boilderplate * Use MVar instead of TVar for server state The main benefit is that we get to use `modifyMVar_` which does updating of the shared state for us (and gracefully handles any uncaught exceptions). * Don't invalidate hashed imports Fixes a misinterpretation on my end of the correct behaviour regarding the caching of imports. Quoting @Gabriel439: > A hashed import is valid indefinitely once it is successfully > resolved, even when the underlying import later becomes broken. That's > why missing sha256:… works so long as the cache has that import cached > (and this behavior is part of the standard). * Cleanup Dhall.LSP.Backend.Dhall a little bit * Add note about fixing cache invalidation * Use TemplateHaskell to generate state lenses * Make types of `typeAt` and `annotateLet` more expressive Both assume the input to be well-typed; by using `WellTyped` rather than `Expr Src X` as the type of their input we can make this explicit. This change exposed a bug (also fixed in this commit) in the type-on-hover functionality: we run `typeAt` only if the input was well-typed _the last time we checked it_ (which was at the last save); this means that if the code changed without being written to disk we would happily try to normalise (in `typeAt`) non-well-typed code... * Fix type of typecheck Typecheck returned the well-typed _type_ of a given expression, while I was assuming it would certify the input to be well-typed. Silly indeed. * Remove `checkDhall` from Dhall.Backend.Diagnostics Removes the left-over stub from the change to the new Dhall backend. * Update comments and remove TODO note * Remove superfluous parentheses * Simplify MonadState code via lens combinators * Use `guard` instead of matching on True * Remove more superfluous parentheses
This commit is contained in:
Frederik Ramcke
GitHub
parent
15e981f61c
commit
41161aa390
|
|
@ -28,11 +28,8 @@ library
|
|||
Dhall.LSP.Backend.ToJSON
|
||||
Dhall.LSP.Backend.Typing
|
||||
Dhall.LSP.Handlers
|
||||
Dhall.LSP.Handlers.Command
|
||||
Dhall.LSP.Handlers.Diagnostics
|
||||
Dhall.LSP.Handlers.DocumentFormatting
|
||||
Dhall.LSP.Handlers.Hover
|
||||
Dhall.LSP.Server
|
||||
Dhall.LSP.State
|
||||
other-modules:
|
||||
Paths_dhall_lsp_server
|
||||
Dhall.LSP.Util
|
||||
|
|
@ -45,9 +42,11 @@ library
|
|||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, cryptonite
|
||||
, data-default
|
||||
, dhall
|
||||
, dhall-json
|
||||
, dotgen
|
||||
, filepath
|
||||
, haskell-lsp
|
||||
, hslogger
|
||||
|
|
@ -55,6 +54,7 @@ library
|
|||
, lens-family-core
|
||||
, megaparsec
|
||||
, mtl
|
||||
, network-uri
|
||||
, optparse-applicative
|
||||
, prettyprinter
|
||||
, sorted-list
|
||||
|
|
|
|||
|
|
@ -1,34 +1,166 @@
|
|||
module Dhall.LSP.Backend.Dhall where
|
||||
module Dhall.LSP.Backend.Dhall (
|
||||
FileIdentifier,
|
||||
fileIdentifierFromFilePath,
|
||||
fileIdentifierFromURI,
|
||||
WellTyped,
|
||||
fromWellTyped,
|
||||
Normal,
|
||||
fromNormal,
|
||||
Cache,
|
||||
emptyCache,
|
||||
cacheExpr,
|
||||
invalidate,
|
||||
DhallError(..),
|
||||
parse,
|
||||
parseWithHeader,
|
||||
load,
|
||||
typecheck,
|
||||
normalize
|
||||
) where
|
||||
|
||||
import Dhall.Import (loadWith, emptyStatus)
|
||||
import Dhall.Parser (Src, exprFromText)
|
||||
import Dhall.Parser (Src)
|
||||
import Dhall.TypeCheck (X)
|
||||
import Dhall.Core (Expr)
|
||||
import Dhall
|
||||
(rootDirectory, sourceName, defaultInputSettings, inputExprWithSettings)
|
||||
|
||||
import qualified Dhall.Core as Dhall
|
||||
import qualified Dhall.Import as Dhall
|
||||
import qualified Dhall.Parser.Token as Dhall
|
||||
import qualified Dhall.Parser as Dhall
|
||||
import qualified Dhall.TypeCheck as Dhall
|
||||
|
||||
import qualified Text.Dot as Dot
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Network.URI as URI
|
||||
import qualified Language.Haskell.LSP.Types as LSP.Types
|
||||
import qualified Data.Text as Text
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty((:|)))
|
||||
import Crypto.Hash (Digest, SHA256)
|
||||
import Data.Text (Text)
|
||||
import System.FilePath (splitFileName)
|
||||
import Lens.Family (set)
|
||||
import Control.Exception (handle, SomeException)
|
||||
import Control.Monad.Trans.State.Strict (evalStateT)
|
||||
import System.FilePath (splitDirectories, takeFileName, takeDirectory)
|
||||
import Lens.Family (view, set)
|
||||
import Control.Exception (SomeException, catch)
|
||||
import Control.Monad.Trans.State.Strict (runStateT)
|
||||
import Network.URI (URI)
|
||||
import Data.Bifunctor (first)
|
||||
|
||||
runDhall :: FilePath -> Text -> IO (Expr Src X)
|
||||
runDhall path = inputExprWithSettings dhallparams
|
||||
-- | A @FileIdentifier@ represents either a local file or a remote url.
|
||||
newtype FileIdentifier = FileIdentifier Dhall.ImportType
|
||||
|
||||
-- | Construct a FileIdentifier from a local file path.
|
||||
fileIdentifierFromFilePath :: FilePath -> FileIdentifier
|
||||
fileIdentifierFromFilePath path =
|
||||
let filename = Text.pack $ takeFileName path
|
||||
directory = takeDirectory path
|
||||
components = map Text.pack . reverse . splitDirectories $ directory
|
||||
in FileIdentifier $ Dhall.Local Dhall.Absolute
|
||||
(Dhall.File (Dhall.Directory components) filename)
|
||||
|
||||
-- | Construct a FileIdentifier from a given URI. Supports "file:", "http:" and
|
||||
-- "https:" URI schemes.
|
||||
fileIdentifierFromURI :: URI -> Maybe FileIdentifier
|
||||
fileIdentifierFromURI uri
|
||||
| URI.uriScheme uri == "file:" = do
|
||||
path <- LSP.Types.uriToFilePath . LSP.Types.Uri . Text.pack
|
||||
$ URI.uriToString id uri ""
|
||||
return $ fileIdentifierFromFilePath path
|
||||
fileIdentifierFromURI uri
|
||||
| otherwise = do
|
||||
url <- Megaparsec.parseMaybe (Dhall.unParser Dhall.httpRaw) . Text.pack
|
||||
$ URI.uriToString id uri ""
|
||||
return $ FileIdentifier (Dhall.Remote url)
|
||||
|
||||
-- | A well-typed expression.
|
||||
newtype WellTyped = WellTyped {fromWellTyped :: Expr Src X}
|
||||
|
||||
-- | A fully normalised expression.
|
||||
newtype Normal = Normal {fromNormal :: Expr Src X}
|
||||
|
||||
-- | A cache maps Dhall imports to fully normalised expressions. By reusing
|
||||
-- caches we can speeds up diagnostics etc. significantly!
|
||||
newtype Cache = Cache (Map.Map Dhall.Import (Dot.NodeId, Expr Src X))
|
||||
|
||||
-- | The initial cache.
|
||||
emptyCache :: Cache
|
||||
emptyCache = Cache Map.empty
|
||||
|
||||
-- | Cache a given normal expression.
|
||||
cacheExpr :: FileIdentifier -> Normal -> Cache -> Cache
|
||||
cacheExpr fileid (Normal expr) (Cache c) =
|
||||
let unhashedImport = importFromFileIdentifier fileid
|
||||
alpha = Dhall.alphaNormalize expr -- we need to alpha-normalise before
|
||||
hash = Dhall.hashExpression maxBound alpha -- calculating the hash
|
||||
hashedImport = hashedImportFromFileIdentifier fileid hash
|
||||
in Cache $ Map.insert unhashedImport (Dot.userNodeId 0, expr)
|
||||
$ Map.insert hashedImport (Dot.userNodeId 0, expr) c
|
||||
|
||||
-- Construct the unhashed import corresponding to the given file.
|
||||
importFromFileIdentifier :: FileIdentifier -> Dhall.Import
|
||||
importFromFileIdentifier (FileIdentifier importType) =
|
||||
Dhall.Import { importHashed = Dhall.ImportHashed Nothing importType,
|
||||
importMode = Dhall.Code }
|
||||
|
||||
|
||||
-- Construct the hashed import corresponding to the given file.
|
||||
hashedImportFromFileIdentifier :: FileIdentifier -> Digest SHA256 -> Dhall.Import
|
||||
hashedImportFromFileIdentifier (FileIdentifier importType) hash =
|
||||
Dhall.Import { importHashed = Dhall.ImportHashed (Just hash) importType,
|
||||
importMode = Dhall.Code }
|
||||
|
||||
-- | Invalidate any _unhashed_ imports of the given file. Hashed imports are
|
||||
-- kept around as per
|
||||
-- https://github.com/dhall-lang/dhall-lang/blob/master/standard/imports.md.
|
||||
-- Note to future self: this doesn't correctly invalidate reverse
|
||||
-- dependencies, i.e. other cached expressions that imported the invalidated
|
||||
-- one. We need to change the representation of the import graph in
|
||||
-- Dhall.Import in order to be able to implement this correctly!
|
||||
invalidate :: FileIdentifier -> Cache -> Cache
|
||||
invalidate (FileIdentifier fileid) (Cache cache) =
|
||||
Cache $ Map.delete codeImport (Map.delete textImport cache)
|
||||
where
|
||||
dhallparams = (set rootDirectory dir . set sourceName file)
|
||||
defaultInputSettings
|
||||
(dir, file) = splitFileName path
|
||||
codeImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.Code
|
||||
textImport = Dhall.Import (Dhall.ImportHashed Nothing fileid) Dhall.RawText
|
||||
|
||||
runDhallSafe :: FilePath -> Text -> IO (Maybe (Expr Src X))
|
||||
runDhallSafe path text = handle (\(_ :: SomeException) -> return Nothing)
|
||||
(Just <$> runDhall path text)
|
||||
-- | A Dhall error. Covers parsing, resolving of imports, typechecking and
|
||||
-- normalisation.
|
||||
data DhallError = ErrorInternal SomeException
|
||||
| ErrorImportSourced (Dhall.SourcedException Dhall.MissingImports)
|
||||
| ErrorTypecheck (Dhall.TypeError Src X)
|
||||
| ErrorParse Dhall.ParseError
|
||||
|
||||
loadDhallExprSafe :: FilePath -> Text -> IO (Maybe (Expr Src X))
|
||||
loadDhallExprSafe filePath txt =
|
||||
case exprFromText filePath txt of
|
||||
Right expr ->
|
||||
let (dir, _) = splitFileName filePath
|
||||
in handle (\(_ :: SomeException) -> return Nothing)
|
||||
(Just <$> evalStateT (loadWith expr) (emptyStatus dir))
|
||||
Left _ -> return Nothing
|
||||
-- | Parse a Dhall expression.
|
||||
parse :: Text -> Either DhallError (Expr Src Dhall.Import)
|
||||
parse = fmap snd . parseWithHeader
|
||||
|
||||
-- | Parse a Dhall expression along with its "header", i.e. whitespace and
|
||||
-- comments prefixing the actual code.
|
||||
parseWithHeader :: Text -> Either DhallError (Text, Expr Src Dhall.Import)
|
||||
parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText ""
|
||||
|
||||
-- | Resolve all imports in an expression.
|
||||
load :: FileIdentifier -> Expr Src Dhall.Import -> Cache ->
|
||||
IO (Either DhallError (Cache, Expr Src X))
|
||||
load fileid expr (Cache cache) = do
|
||||
let emptyStatus = Dhall.emptyStatus ""
|
||||
status = -- reuse cache
|
||||
set Dhall.cache cache .
|
||||
-- set "root import"
|
||||
set Dhall.stack (importFromFileIdentifier fileid :| [])
|
||||
$ emptyStatus
|
||||
(do (expr', status') <- runStateT (Dhall.loadWith expr) status
|
||||
let cache' = Cache $ view Dhall.cache status'
|
||||
return . Right $ (cache', expr'))
|
||||
`catch` (\e -> return . Left $ ErrorImportSourced e)
|
||||
`catch` (\e -> return . Left $ ErrorInternal e)
|
||||
|
||||
-- | Typecheck a fully resolved expression. Returns a certification that the
|
||||
-- input was well-typed along with its (well-typed) type.
|
||||
typecheck :: Expr Src X -> Either DhallError (WellTyped, WellTyped)
|
||||
typecheck expr = case Dhall.typeOf expr of
|
||||
Left err -> Left $ ErrorTypecheck err
|
||||
Right typ -> Right (WellTyped expr, WellTyped typ)
|
||||
|
||||
-- | Normalise a well-typed expression.
|
||||
normalize :: WellTyped -> Normal
|
||||
normalize (WellTyped expr) = Normal $ Dhall.normalize expr
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Dhall.LSP.Backend.Diagnostics
|
||||
( DhallException
|
||||
, checkDhall
|
||||
( DhallError
|
||||
, diagnose
|
||||
, Diagnosis(..)
|
||||
, explain
|
||||
|
|
@ -16,32 +15,18 @@ module Dhall.LSP.Backend.Diagnostics
|
|||
)
|
||||
where
|
||||
|
||||
import Dhall.Binary (DecodingFailure)
|
||||
import Dhall.Parser (ParseError, SourcedException(..), Src(..), unwrap)
|
||||
import Dhall.Import (MissingImports)
|
||||
import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..), X)
|
||||
import Dhall.Parser (SourcedException(..), Src(..), unwrap)
|
||||
import Dhall.TypeCheck (DetailedTypeError(..), TypeError(..))
|
||||
import Dhall.Core (Expr(Note))
|
||||
|
||||
import Dhall.LSP.Util
|
||||
import Dhall.LSP.Backend.Dhall (runDhall)
|
||||
import Dhall.LSP.Backend.Dhall
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Control.Exception (handle, SomeException)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
|
||||
-- | An exception that occurred while trying to parse, type-check and normalise
|
||||
-- the input. TODO: make this list exhaustive! We currently report too many
|
||||
-- exceptions as "internal errors".
|
||||
data DhallException
|
||||
= ExceptionInternal SomeException
|
||||
| ExceptionCBOR DecodingFailure -- CBOR decoding failure (not relevant?)
|
||||
| ExceptionImport (SourcedException MissingImports) -- Failure to resolve an import statement
|
||||
| ExceptionTypecheck (TypeError Src X) -- Input does not type-check
|
||||
| ExceptionParse ParseError -- Input does not parse
|
||||
|
||||
|
||||
-- | A (line, col) pair representing a position in a source file; 0-based.
|
||||
type Position = (Int, Int)
|
||||
-- | A source code range.
|
||||
|
|
@ -55,23 +40,9 @@ data Diagnosis = Diagnosis {
|
|||
}
|
||||
|
||||
|
||||
-- | Parse, type-check and normalise the given Dhall code, collecting any
|
||||
-- occurring errors.
|
||||
checkDhall :: FilePath -> Text -> IO [DhallException]
|
||||
checkDhall path txt =
|
||||
(handle' ExceptionInternal
|
||||
. handle' ExceptionCBOR
|
||||
. handle' ExceptionImport
|
||||
. handle' ExceptionTypecheck
|
||||
. handle' ExceptionParse
|
||||
)
|
||||
(const [] <$> runDhall path txt)
|
||||
where
|
||||
handle' constructor = handle (return . return . constructor)
|
||||
|
||||
-- | Give a short diagnosis for a given error that can be shown to the end user.
|
||||
diagnose :: Text -> DhallException -> [Diagnosis]
|
||||
diagnose _ (ExceptionInternal e) = [Diagnosis { .. }]
|
||||
diagnose :: Text -> DhallError -> [Diagnosis]
|
||||
diagnose _ (ErrorInternal e) = [Diagnosis { .. }]
|
||||
where
|
||||
doctor = "Dhall"
|
||||
range = Nothing
|
||||
|
|
@ -79,25 +50,19 @@ diagnose _ (ExceptionInternal e) = [Diagnosis { .. }]
|
|||
"An internal error has occurred while trying to process the Dhall file: "
|
||||
<> tshow e
|
||||
|
||||
diagnose _ (ExceptionCBOR t) = [Diagnosis { .. }]
|
||||
where
|
||||
doctor = "Dhall.Binary"
|
||||
range = Nothing
|
||||
diagnosis = "Failed to decode CBOR Dhall representation: " <> tshow t
|
||||
|
||||
diagnose txt (ExceptionImport (SourcedException src e)) = [Diagnosis { .. }]
|
||||
diagnose txt (ErrorImportSourced (SourcedException src e)) = [Diagnosis { .. }]
|
||||
where
|
||||
doctor = "Dhall.Import"
|
||||
range = (Just . sanitiseRange txt . rangeFromDhall) src
|
||||
diagnosis = tshow e
|
||||
|
||||
diagnose txt (ExceptionTypecheck e@(TypeError _ expr _)) = [Diagnosis { .. }]
|
||||
diagnose txt (ErrorTypecheck e@(TypeError _ expr _)) = [Diagnosis { .. }]
|
||||
where
|
||||
doctor = "Dhall.TypeCheck"
|
||||
range = fmap (sanitiseRange txt . rangeFromDhall) (note expr)
|
||||
diagnosis = tshow e
|
||||
|
||||
diagnose txt (ExceptionParse e) =
|
||||
diagnose txt (ErrorParse e) =
|
||||
[ Diagnosis { .. } | (diagnosis, range) <- zip diagnoses (map Just ranges) ]
|
||||
where
|
||||
doctor = "Dhall.Parser"
|
||||
|
|
@ -126,8 +91,8 @@ diagnose txt (ExceptionParse e) =
|
|||
|
||||
-- | Give a detailed explanation for the given error; if no detailed explanation
|
||||
-- is available return @Nothing@ instead.
|
||||
explain :: Text -> DhallException -> Maybe Diagnosis
|
||||
explain txt (ExceptionTypecheck e@(TypeError _ expr _)) = Just
|
||||
explain :: Text -> DhallError -> Maybe Diagnosis
|
||||
explain txt (ErrorTypecheck e@(TypeError _ expr _)) = Just
|
||||
(Diagnosis { .. })
|
||||
where
|
||||
doctor = "Dhall.TypeCheck"
|
||||
|
|
|
|||
|
|
@ -1,23 +1,24 @@
|
|||
module Dhall.LSP.Backend.Formatting (formatDocument, formatExpr) where
|
||||
module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where
|
||||
|
||||
import Dhall.Core (Expr)
|
||||
import Dhall.Pretty (CharacterSet(..), layoutOpts, prettyCharacterSet)
|
||||
import Dhall.Parser(exprAndHeaderFromText, ParseError(..))
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
||||
|
||||
formatDocument :: Text -> Either ParseError Text
|
||||
formatDocument text = do
|
||||
(header, expr) <- exprAndHeaderFromText "" text
|
||||
pure (formatExpr header expr)
|
||||
-- | Pretty-print the given Dhall expression.
|
||||
formatExpr :: Pretty.Pretty b => Expr a b -> Text
|
||||
formatExpr expr = formatExprWithHeader expr ""
|
||||
|
||||
formatExpr :: Pretty.Pretty b => Text -> Expr a b -> Text
|
||||
formatExpr header expr = Pretty.renderStrict
|
||||
-- | Pretty-print the given Dhall expression, prepending the given a "header"
|
||||
-- (usually consisting of comments and whitespace).
|
||||
formatExprWithHeader :: Pretty.Pretty b => Expr a b -> Text -> Text
|
||||
formatExprWithHeader expr header = Pretty.renderStrict
|
||||
(Pretty.layoutSmart layoutOpts doc)
|
||||
where
|
||||
doc =
|
||||
Pretty.pretty header
|
||||
<> Pretty.unAnnotate (prettyCharacterSet Unicode expr)
|
||||
<> "\n"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,14 @@
|
|||
module Dhall.LSP.Backend.Linting
|
||||
( suggest
|
||||
, Suggestion(..)
|
||||
, lintAndFormatDocument
|
||||
( Suggestion(..)
|
||||
, suggest
|
||||
, Dhall.lint
|
||||
)
|
||||
where
|
||||
|
||||
import Dhall.Parser (Src, ParseError, exprFromText, exprAndHeaderFromText)
|
||||
import Dhall.Core (Expr(..), Binding(..), Var(..), subExpressions, freeIn)
|
||||
import Dhall.Lint (lint)
|
||||
import Dhall.Parser (Src)
|
||||
import Dhall.Core (Expr(..), Binding(..), Var(..), subExpressions, freeIn, Import)
|
||||
import qualified Dhall.Lint as Dhall
|
||||
|
||||
import Dhall.LSP.Backend.Formatting
|
||||
import Dhall.LSP.Backend.Diagnostics
|
||||
|
||||
import Data.Text (Text)
|
||||
|
|
@ -21,13 +20,13 @@ data Suggestion = Suggestion {
|
|||
suggestion :: Text
|
||||
}
|
||||
|
||||
-- Diagnose nested Let blocks.
|
||||
-- Diagnose nested let blocks.
|
||||
diagLetInLet :: Expr Src a -> [Suggestion]
|
||||
diagLetInLet (Note _ (Let _ (Note src (Let _ _)))) =
|
||||
[Suggestion (rangeFromDhall src) "Superfluous 'in' before nested let binding"]
|
||||
diagLetInLet _ = []
|
||||
|
||||
-- Given a (noted) Let block compute all unused variables in the block.
|
||||
-- Given a (noted) let block compute all unused variables in the block.
|
||||
unusedBindings :: Eq a => Expr s a -> [Text]
|
||||
unusedBindings (Note _ (Let bindings d)) = concatMap
|
||||
(\case
|
||||
|
|
@ -37,7 +36,7 @@ unusedBindings (Note _ (Let bindings d)) = concatMap
|
|||
(toList $ tails bindings)
|
||||
unusedBindings _ = []
|
||||
|
||||
-- Diagnose unused Let bindings.
|
||||
-- Diagnose unused let bindings.
|
||||
diagUnusedBinding :: Eq a => Expr Src a -> [Suggestion]
|
||||
diagUnusedBinding e@(Note src (Let _ _)) = map
|
||||
(\var ->
|
||||
|
|
@ -47,14 +46,6 @@ diagUnusedBinding _ = []
|
|||
|
||||
-- | Given an dhall expression suggest all the possible improvements that would
|
||||
-- be made by the linter.
|
||||
suggest :: Text -> [Suggestion]
|
||||
suggest txt = case exprFromText "" txt of
|
||||
Right expr -> concat [ diagLetInLet e ++ diagUnusedBinding e
|
||||
| e <- universeOf subExpressions expr ]
|
||||
_ -> []
|
||||
|
||||
lintAndFormatDocument :: Text -> Either ParseError Text
|
||||
lintAndFormatDocument text = do
|
||||
(header, expr) <- exprAndHeaderFromText "" text
|
||||
let expr' = lint expr
|
||||
pure (formatExpr header expr')
|
||||
suggest :: Expr Src Import -> [Suggestion]
|
||||
suggest expr = concat [ diagLetInLet e ++ diagUnusedBinding e
|
||||
| e <- universeOf subExpressions expr ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
module Dhall.LSP.Backend.ToJSON where
|
||||
module Dhall.LSP.Backend.ToJSON (CompileError, toJSON) where
|
||||
|
||||
import qualified Dhall.JSON as Dhall
|
||||
import Dhall.JSON as Dhall
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
|
||||
import Dhall.LSP.Backend.Dhall
|
||||
|
|
@ -9,19 +9,13 @@ import Data.Text (Text)
|
|||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.ByteString.Lazy (toStrict)
|
||||
|
||||
-- | Try to convert the given Dhall file to JSON.
|
||||
dhallToJSON :: FilePath -> Text -> IO (Maybe Text)
|
||||
dhallToJSON path text = do
|
||||
mexpr <- runDhallSafe path text
|
||||
case mexpr of
|
||||
Just expr -> case Dhall.dhallToJSON expr of
|
||||
Right value -> do
|
||||
let config = Aeson.Config
|
||||
-- | Try to convert a given Dhall expression to JSON.
|
||||
toJSON :: WellTyped -> Either CompileError Text
|
||||
toJSON expr = fmap (decodeUtf8 . toStrict . Aeson.encodePretty' config)
|
||||
(Dhall.dhallToJSON $ fromWellTyped expr)
|
||||
where
|
||||
config = Aeson.Config
|
||||
{ Aeson.confIndent = Aeson.Spaces 2
|
||||
, Aeson.confCompare = compare
|
||||
, Aeson.confNumFormat = Aeson.Generic
|
||||
, Aeson.confTrailingNewline = False }
|
||||
return . Just . decodeUtf8 . toStrict $
|
||||
Aeson.encodePretty' config value
|
||||
_ -> return Nothing
|
||||
Nothing -> return Nothing
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import Data.Bifunctor (first)
|
|||
|
||||
import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot)
|
||||
import Dhall.LSP.Backend.Diagnostics (Position, positionFromMegaparsec, offsetToPosition)
|
||||
import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
|
||||
|
||||
import qualified Data.Text.Prettyprint.Doc as Pretty
|
||||
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
|
||||
|
|
@ -21,9 +22,9 @@ import Dhall.Pretty (CharacterSet(..), prettyCharacterSet)
|
|||
|
||||
-- | Find the type of the subexpression at the given position. Assumes that the
|
||||
-- input expression is well-typed.
|
||||
typeAt :: Position -> Expr Src X -> Either String (Expr Src X)
|
||||
typeAt :: Position -> WellTyped -> Either String (Expr Src X)
|
||||
typeAt pos expr = do
|
||||
expr' <- case splitLets expr of
|
||||
expr' <- case splitLets (fromWellTyped expr) of
|
||||
Just e -> return e
|
||||
Nothing -> Left "The impossible happened: failed to split let\
|
||||
\ blocks when preprocessing for typeAt'."
|
||||
|
|
@ -85,9 +86,9 @@ srcAt pos expr = do Note src _ <- exprAt pos expr
|
|||
-- position (if there is one) and return a textual update to the source code
|
||||
-- that inserts the type annotation (or replaces the existing one). If
|
||||
-- something goes wrong returns a textual error message.
|
||||
annotateLet :: Position -> Expr Src X -> Either String (Src, Text)
|
||||
annotateLet :: Position -> WellTyped -> Either String (Src, Text)
|
||||
annotateLet pos expr = do
|
||||
expr' <- case splitLets expr of
|
||||
expr' <- case splitLets (fromWellTyped expr) of
|
||||
Just e -> return e
|
||||
Nothing -> Left "The impossible happened: failed to split let\
|
||||
\ blocks when preprocessing for annotateLet'."
|
||||
|
|
|
|||
|
|
@ -2,59 +2,345 @@ module Dhall.LSP.Handlers where
|
|||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Utility as LSP
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
import qualified Language.Haskell.LSP.VFS as LSP
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Yi.Rope as Rope
|
||||
|
||||
import Dhall.Core (Expr, pretty)
|
||||
import Dhall.Parser (Src(..))
|
||||
import Dhall.TypeCheck (X)
|
||||
|
||||
import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
|
||||
normalize, fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate,
|
||||
cacheExpr, parseWithHeader, fromWellTyped)
|
||||
import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
|
||||
sanitiseRange, rangeFromDhall, diagnose)
|
||||
import Dhall.LSP.Backend.Formatting (formatExprWithHeader)
|
||||
import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
|
||||
import Dhall.LSP.Backend.Typing (typeAt, srcAt, annotateLet)
|
||||
import Dhall.LSP.State
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Lens ((^.), use, uses, assign, modifying)
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Control.Monad.Trans.Except (throwE, catchE, runExceptT)
|
||||
import Control.Monad.Trans.State.Strict (execStateT)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Network.URI as URI
|
||||
import qualified Network.URI.Encode as URI
|
||||
import Text.Megaparsec (SourcePos(..), unPos)
|
||||
|
||||
|
||||
-- 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
|
||||
-- LSP `ShowMessage` notification.
|
||||
wrapHandler
|
||||
:: MVar ServerState
|
||||
-> (a -> HandlerM ())
|
||||
-> a
|
||||
-> IO ()
|
||||
wrapHandler vstate handle message =
|
||||
modifyMVar_ vstate $
|
||||
execStateT . runExceptT $
|
||||
catchE (handle message) lspUserMessage
|
||||
|
||||
lspUserMessage :: (Severity, Text) -> HandlerM ()
|
||||
lspUserMessage (Log, text) =
|
||||
lspSendNotification LSP.NotLogMessage J.WindowLogMessage
|
||||
$ J.LogMessageParams J.MtLog text
|
||||
lspUserMessage (severity, text) =
|
||||
lspSendNotification LSP.NotShowMessage J.WindowShowMessage
|
||||
$ J.ShowMessageParams severity' text
|
||||
where severity' = case severity of
|
||||
Error -> J.MtError
|
||||
Warning -> J.MtWarning
|
||||
Info -> J.MtInfo
|
||||
Log -> J.MtLog
|
||||
|
||||
|
||||
lspSend :: LSP.FromServerMessage -> HandlerM ()
|
||||
lspSend msg = do
|
||||
send <- use (lspFuncs . sendFunc)
|
||||
liftIO $ send msg
|
||||
|
||||
lspRespond :: (J.ResponseMessage response -> LSP.FromServerMessage)
|
||||
-> J.RequestMessage J.ClientMethod request response -> response -> HandlerM ()
|
||||
lspRespond constructor request response =
|
||||
lspSend . constructor $ LSP.makeResponseMessage request response
|
||||
|
||||
lspSendNotification
|
||||
:: (J.NotificationMessage J.ServerMethod params -> LSP.FromServerMessage)
|
||||
-> J.ServerMethod -> params -> HandlerM ()
|
||||
lspSendNotification constructor method params =
|
||||
lspSend . constructor $ J.NotificationMessage "2.0" method params
|
||||
|
||||
lspRequest
|
||||
:: (J.RequestMessage J.ServerMethod params response -> LSP.FromServerMessage)
|
||||
-> J.ServerMethod -> params -> HandlerM ()
|
||||
lspRequest constructor method params = do
|
||||
getNextReqId <- uses lspFuncs LSP.getNextReqId
|
||||
reqId <- liftIO getNextReqId
|
||||
lspSend . constructor $ J.RequestMessage "2.0" reqId method params
|
||||
|
||||
-- | A helper function to query haskell-lsp's VFS.
|
||||
readUri :: J.Uri -> HandlerM Text
|
||||
readUri uri = do
|
||||
getVirtualFileFunc <- uses lspFuncs LSP.getVirtualFileFunc
|
||||
mVirtualFile <- liftIO $ getVirtualFileFunc uri
|
||||
case mVirtualFile of
|
||||
Just (LSP.VirtualFile _ rope) -> return (Rope.toText rope)
|
||||
Nothing -> fail $ "Could not find " <> show uri <> " in VFS."
|
||||
|
||||
loadFile :: J.Uri -> HandlerM (Expr Src X)
|
||||
loadFile uri = do
|
||||
txt <- readUri uri
|
||||
fileIdentifier <- fileIdentifierFromUri uri
|
||||
cache <- use importCache
|
||||
|
||||
expr <- case parse txt of
|
||||
Right e -> return e
|
||||
_ -> throwE (Error, "Failed to parse Dhall file.")
|
||||
|
||||
loaded <- liftIO $ load fileIdentifier expr cache
|
||||
(cache', expr') <- case loaded of
|
||||
Right x -> return x
|
||||
_ -> throwE (Error, "Failed to resolve imports.")
|
||||
-- Update cache. Don't cache current expression because it might not have been
|
||||
-- written to disk yet (readUri reads from the VFS).
|
||||
assign importCache cache'
|
||||
return expr'
|
||||
|
||||
-- helper
|
||||
fileIdentifierFromUri :: J.Uri -> HandlerM FileIdentifier
|
||||
fileIdentifierFromUri uri =
|
||||
let mFileIdentifier = fmap fileIdentifierFromFilePath (J.uriToFilePath uri)
|
||||
<|> (do uri' <- (URI.parseURI . Text.unpack . J.getUri) uri
|
||||
fileIdentifierFromURI uri')
|
||||
in case mFileIdentifier of
|
||||
Just fileIdentifier -> return fileIdentifier
|
||||
Nothing -> throwE (Error, J.getUri uri <> " is not a valid name for a dhall file.")
|
||||
|
||||
-- helper
|
||||
rangeToJSON :: Range -> J.Range
|
||||
rangeToJSON (Range (x1,y1) (x2,y2)) = J.Range (J.Position x1 y1) (J.Position x2 y2)
|
||||
|
||||
hoverExplain :: J.HoverRequest -> HandlerM ()
|
||||
hoverExplain request = do
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
J.Position line col = request ^. J.params . J.position
|
||||
txt <- readUri uri
|
||||
mError <- uses errors $ Map.lookup uri
|
||||
let isHovered (Diagnosis _ (Just (Range left right)) _) =
|
||||
left <= (line,col) && (line,col) <= right
|
||||
isHovered _ = False
|
||||
|
||||
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) =
|
||||
let _range = Just $ J.Range (uncurry J.Position left)
|
||||
(uncurry J.Position right)
|
||||
encodedDiag = URI.encode (Text.unpack diagnosis)
|
||||
command = "[Explain error](dhall-explain:?"
|
||||
<> Text.pack encodedDiag <> " )"
|
||||
_contents = J.List [J.PlainString command]
|
||||
in Just J.Hover { .. }
|
||||
hoverFromDiagnosis _ = Nothing
|
||||
|
||||
mHover = do err <- mError
|
||||
explanation <- explain txt err
|
||||
guard (isHovered explanation)
|
||||
hoverFromDiagnosis explanation
|
||||
lspRespond LSP.RspHover request mHover
|
||||
|
||||
hoverType :: J.HoverRequest -> HandlerM ()
|
||||
hoverType request = do
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
J.Position line col = request ^. J.params . J.position
|
||||
txt <- readUri uri
|
||||
expr <- loadFile uri
|
||||
(welltyped, _) <- case typecheck expr of
|
||||
Left _ -> throwE (Info, "Can't infer type; code does not type-check.")
|
||||
Right wt -> return wt
|
||||
case typeAt (line,col) welltyped of
|
||||
Left err -> throwE (Error, Text.pack err)
|
||||
Right typ ->
|
||||
let _range = fmap (rangeToJSON . sanitiseRange txt . rangeFromDhall)
|
||||
(srcAt (line,col) (fromWellTyped welltyped))
|
||||
_contents = J.List [J.PlainString (pretty typ)]
|
||||
hover = J.Hover{..}
|
||||
in lspRespond LSP.RspHover request (Just hover)
|
||||
|
||||
hoverHandler :: J.HoverRequest -> HandlerM ()
|
||||
hoverHandler request = do
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
errorMap <- use errors
|
||||
case Map.lookup uri errorMap of
|
||||
Nothing -> hoverType request
|
||||
_ -> hoverExplain request
|
||||
|
||||
|
||||
diagnosticsHandler :: J.Uri -> HandlerM ()
|
||||
diagnosticsHandler uri = do
|
||||
txt <- readUri uri
|
||||
fileIdentifier <- fileIdentifierFromUri uri
|
||||
-- make sure we don't keep a stale version around
|
||||
modifying importCache (invalidate fileIdentifier)
|
||||
cache <- use importCache
|
||||
|
||||
errs <- flip catchE (return . Just) $ do
|
||||
expr <- case parse txt of
|
||||
Right e -> return e
|
||||
Left err -> throwE err
|
||||
loaded <- liftIO $ load fileIdentifier expr cache
|
||||
(cache', expr') <- case loaded of
|
||||
Right x -> return x
|
||||
Left err -> throwE err
|
||||
welltyped <- case typecheck expr' of
|
||||
Right (wt, _typ) -> return wt
|
||||
Left err -> throwE err
|
||||
let normal = normalize welltyped
|
||||
-- cache the new expression
|
||||
assign importCache (cacheExpr fileIdentifier normal cache')
|
||||
return Nothing
|
||||
|
||||
let suggestions =
|
||||
case parse txt of
|
||||
Right expr -> suggest expr
|
||||
_ -> []
|
||||
|
||||
suggestionToDiagnostic Suggestion {..} =
|
||||
let _range = rangeToJSON range
|
||||
_severity = Just J.DsHint
|
||||
_source = Just "Dhall.Lint"
|
||||
_code = Nothing
|
||||
_message = suggestion
|
||||
_relatedInformation = Nothing
|
||||
in J.Diagnostic {..}
|
||||
|
||||
diagnosisToDiagnostic Diagnosis {..} =
|
||||
let _range = case range of
|
||||
Just range' ->
|
||||
rangeToJSON range'
|
||||
Nothing -> J.Range (J.Position 0 0) (J.Position 0 0)
|
||||
_severity = Just J.DsError
|
||||
_source = Just doctor
|
||||
_code = Nothing
|
||||
_message = diagnosis
|
||||
_relatedInformation = Nothing
|
||||
in J.Diagnostic {..}
|
||||
|
||||
diagnostics = concatMap (map diagnosisToDiagnostic . diagnose txt) (maybeToList errs)
|
||||
++ map suggestionToDiagnostic suggestions
|
||||
|
||||
modifying errors (Map.alter (const errs) uri) -- cache errors
|
||||
lspSendNotification LSP.NotPublishDiagnostics J.TextDocumentPublishDiagnostics
|
||||
(J.PublishDiagnosticsParams uri (J.List diagnostics))
|
||||
|
||||
|
||||
documentFormattingHandler :: J.DocumentFormattingRequest -> HandlerM ()
|
||||
documentFormattingHandler request = do
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
txt <- readUri uri
|
||||
|
||||
(header, expr) <- case parseWithHeader txt of
|
||||
Right res -> return res
|
||||
_ -> throwE (Warning, "Failed to format dhall code; parse error.")
|
||||
|
||||
let formatted = formatExprWithHeader expr header
|
||||
numLines = Text.length txt
|
||||
range = J.Range (J.Position 0 0) (J.Position numLines 0)
|
||||
edits = J.List [J.TextEdit range formatted]
|
||||
|
||||
lspRespond LSP.RspDocumentFormatting request edits
|
||||
|
||||
|
||||
executeCommandHandler :: J.ExecuteCommandRequest -> HandlerM ()
|
||||
executeCommandHandler request
|
||||
| command == "dhall.server.lint" = executeLintAndFormat request
|
||||
| command == "dhall.server.annotateLet" = executeAnnotateLet request
|
||||
| otherwise = throwE (Warning, "Command '" <> command
|
||||
<> "' not known; ignored.")
|
||||
where command = request ^. J.params . J.command
|
||||
|
||||
getCommandArguments :: J.FromJSON a => J.ExecuteCommandRequest -> HandlerM a
|
||||
getCommandArguments request = do
|
||||
json <- case request ^. J.params . J.arguments of
|
||||
Just (J.List (x : _)) -> return x
|
||||
_ -> throwE (Error, "Failed to execute command; arguments missing.")
|
||||
case J.fromJSON json of
|
||||
J.Success args -> return args
|
||||
_ -> throwE (Error, "Failed to execute command; failed to parse arguments.")
|
||||
|
||||
|
||||
-- implements dhall.server.lint
|
||||
executeLintAndFormat :: J.ExecuteCommandRequest -> HandlerM ()
|
||||
executeLintAndFormat request = do
|
||||
uri <- getCommandArguments request
|
||||
txt <- readUri uri
|
||||
|
||||
(header, expr) <- case parseWithHeader txt of
|
||||
Right res -> return res
|
||||
_ -> throwE (Warning, "Failed to lint dhall code; parse error.")
|
||||
|
||||
let linted = formatExprWithHeader (lint expr) header
|
||||
numLines = Text.length txt
|
||||
range = J.Range (J.Position 0 0) (J.Position numLines 0)
|
||||
edit = J.WorkspaceEdit
|
||||
(Just (HashMap.singleton uri (J.List [J.TextEdit range linted]))) Nothing
|
||||
|
||||
lspRespond LSP.RspExecuteCommand request J.Null
|
||||
lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit
|
||||
(J.ApplyWorkspaceEditParams edit)
|
||||
|
||||
|
||||
executeAnnotateLet :: J.ExecuteCommandRequest -> HandlerM ()
|
||||
executeAnnotateLet request = do
|
||||
args :: J.TextDocumentPositionParams <- getCommandArguments request
|
||||
let uri = args ^. J.textDocument . J.uri
|
||||
line = args ^. J.position . J.line
|
||||
col = args ^. J.position . J.character
|
||||
|
||||
expr <- loadFile uri
|
||||
(welltyped, _) <- case typecheck expr of
|
||||
Left _ -> throwE (Warning, "Failed to annotate let binding; not well-typed.")
|
||||
Right e -> return e
|
||||
|
||||
(Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _, txt)
|
||||
<- case annotateLet (line, col) welltyped of
|
||||
Right x -> return x
|
||||
Left msg -> throwE (Warning, Text.pack msg)
|
||||
|
||||
let range = J.Range (J.Position (unPos x1 - 1) (unPos y1 - 1))
|
||||
(J.Position (unPos x2 - 1) (unPos y2 - 1))
|
||||
edit = J.WorkspaceEdit
|
||||
(Just (HashMap.singleton uri (J.List [J.TextEdit range txt]))) Nothing
|
||||
|
||||
lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit
|
||||
(J.ApplyWorkspaceEditParams edit)
|
||||
|
||||
|
||||
import qualified Dhall.LSP.Handlers.Diagnostics as Diagnostics
|
||||
import qualified Dhall.LSP.Handlers.DocumentFormatting as Formatting
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
|
||||
-- handler that doesn't do anything. Useful for example to make haskell-lsp shut
|
||||
-- up about unhandled DidChangeTextDocument notifications (which are already
|
||||
-- handled haskell-lsp itself).
|
||||
nullHandler :: LSP.LspFuncs () -> a -> IO ()
|
||||
nullHandler _ _ = return ()
|
||||
|
||||
{- Currently implemented by the dummy nullHandler:
|
||||
initializedHandler :: LSP.LspFuncs () -> J.InitializedNotification -> IO ()
|
||||
|
||||
didChangeTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidChangeTextDocumentNotification -> IO ()
|
||||
|
||||
didCloseTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidCloseTextDocumentNotification -> IO ()
|
||||
|
||||
cancelNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.CancelNotification -> IO ()
|
||||
|
||||
responseHandler :: LSP.LspFuncs () -> J.BareResponseMessage -> IO ()
|
||||
-}
|
||||
nullHandler :: a -> HandlerM ()
|
||||
nullHandler _ = return ()
|
||||
|
||||
didOpenTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidOpenTextDocumentNotification -> IO ()
|
||||
didOpenTextDocumentNotificationHandler lsp notification = do
|
||||
LSP.logs "LSP Handler: processing DidOpenTextDocumentNotification"
|
||||
:: J.DidOpenTextDocumentNotification -> HandlerM ()
|
||||
didOpenTextDocumentNotificationHandler notification = do
|
||||
let uri = notification ^. J.params . J.textDocument . J.uri
|
||||
Diagnostics.diagnosticsHandler lsp uri
|
||||
diagnosticsHandler uri
|
||||
|
||||
didSaveTextDocumentNotificationHandler
|
||||
:: LSP.LspFuncs () -> J.DidSaveTextDocumentNotification -> IO ()
|
||||
didSaveTextDocumentNotificationHandler lsp notification = do
|
||||
LSP.logs "LSP Handler: processing DidSaveTextDocumentNotification"
|
||||
:: J.DidSaveTextDocumentNotification -> HandlerM ()
|
||||
didSaveTextDocumentNotificationHandler notification = do
|
||||
let uri = notification ^. J.params . J.textDocument . J.uri
|
||||
Diagnostics.diagnosticsHandler lsp uri
|
||||
|
||||
documentFormattingHandler
|
||||
:: LSP.LspFuncs () -> J.DocumentFormattingRequest -> IO ()
|
||||
documentFormattingHandler lsp request = do
|
||||
LSP.logs "LSP Handler: processing DocumentFormattingRequest"
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
formattedDocument <- flip runReaderT lsp
|
||||
$ Formatting.formatDocument uri undefined undefined
|
||||
LSP.sendFunc lsp $ LSP.RspDocumentFormatting $ LSP.makeResponseMessage
|
||||
request
|
||||
formattedDocument
|
||||
diagnosticsHandler uri
|
||||
|
|
|
|||
|
|
@ -1,142 +0,0 @@
|
|||
module Dhall.LSP.Handlers.Command (executeCommandHandler) where
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Utility as LSP
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
|
||||
import Dhall.LSP.Backend.Dhall
|
||||
import qualified Dhall.LSP.Backend.Linting as Linting
|
||||
import qualified Dhall.LSP.Backend.ToJSON as ToJSON
|
||||
import Dhall.LSP.Util (readUri)
|
||||
import Dhall.LSP.Backend.Typing (annotateLet)
|
||||
|
||||
import System.FilePath (replaceExtension)
|
||||
import Data.HashMap.Strict (singleton)
|
||||
import Control.Lens ((^.))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.Trans.Except (runExceptT, throwE, ExceptT)
|
||||
|
||||
import Text.Megaparsec (SourcePos(..), unPos)
|
||||
import Dhall.Parser (Src(..))
|
||||
|
||||
executeCommandHandler :: LSP.LspFuncs () -> J.ExecuteCommandRequest -> IO ()
|
||||
executeCommandHandler lsp request
|
||||
| command == "dhall.server.lint" = case parseUriArgument request of
|
||||
Right uri -> executeLintAndFormat lsp uri
|
||||
Left msg -> LSP.logs msg
|
||||
| command == "dhall.server.toJSON" = case parseUriArgument request of
|
||||
Right uri -> executeDhallToJSON lsp uri
|
||||
Left msg -> LSP.logs msg
|
||||
| command == "dhall.server.annotateLet" = executeAnnotateLet lsp request
|
||||
| otherwise = LSP.logs
|
||||
("LSP Handler: asked to execute unknown command: " ++ show command)
|
||||
where command = request ^. J.params . J.command
|
||||
|
||||
-- implements dhall.server.toJSON
|
||||
executeDhallToJSON :: LSP.LspFuncs () -> J.Uri -> IO ()
|
||||
executeDhallToJSON lsp uri = do
|
||||
txt <- readUri lsp uri
|
||||
let filepath = case J.uriToFilePath uri of
|
||||
Nothing -> fail "Failed to parse URI when converting Dhall to JSON."
|
||||
Just path -> path
|
||||
mconverted <- ToJSON.dhallToJSON filepath txt
|
||||
case mconverted of
|
||||
Just converted -> do
|
||||
let edit = J.List [ J.TextEdit (J.Range (J.Position 0 0) (J.Position 0 0))
|
||||
converted ]
|
||||
-- TODO: this doesn't work; we need to fix haskell-lsp-types to
|
||||
-- support file creation!
|
||||
edits = case appendSuffixToUri uri ".json" of
|
||||
Right uri' -> Just (singleton uri' edit)
|
||||
_ -> Nothing
|
||||
lid <- LSP.getNextReqId lsp
|
||||
LSP.sendFunc lsp $ LSP.ReqApplyWorkspaceEdit
|
||||
$ LSP.fmServerApplyWorkspaceEditRequest lid
|
||||
$ J.ApplyWorkspaceEditParams
|
||||
$ J.WorkspaceEdit edits Nothing
|
||||
Nothing -> LSP.sendFunc lsp $ LSP.NotShowMessage
|
||||
$ LSP.fmServerShowMessageNotification J.MtError
|
||||
"Failed to convert Dhall to JSON. Make sure\
|
||||
\ the Dhall file is free of errors first!"
|
||||
|
||||
-- implements dhall.server.lint
|
||||
executeLintAndFormat :: LSP.LspFuncs () -> J.Uri -> IO ()
|
||||
executeLintAndFormat lsp uri = do
|
||||
txt <- readUri lsp uri
|
||||
case Linting.lintAndFormatDocument txt of
|
||||
Right linted -> do
|
||||
let endline = length $ Text.lines txt
|
||||
let edit = J.List [ J.TextEdit
|
||||
(J.Range (J.Position 0 0) (J.Position endline 0))
|
||||
linted ]
|
||||
lid <- LSP.getNextReqId lsp
|
||||
LSP.sendFunc lsp $ LSP.ReqApplyWorkspaceEdit
|
||||
$ LSP.fmServerApplyWorkspaceEditRequest lid
|
||||
$ J.ApplyWorkspaceEditParams
|
||||
$ J.WorkspaceEdit (Just (singleton uri edit)) Nothing
|
||||
_ -> LSP.logs "LSP Handler: linting failed"
|
||||
|
||||
-- Helper that appends a suffix to a uri. Fails if the uri does not represent a
|
||||
-- file path.
|
||||
appendSuffixToUri :: J.Uri -> Text -> Either String J.Uri
|
||||
appendSuffixToUri uri suffix = case J.uriToFilePath uri of
|
||||
Just path -> Right . J.filePathToUri $ replaceExtension path (show suffix)
|
||||
Nothing -> Left $ "failed to append suffix to uri " ++ show uri
|
||||
++ " because it's not a valid file path"
|
||||
|
||||
parseUriArgument :: J.ExecuteCommandRequest -> Either String J.Uri
|
||||
parseUriArgument request = case request ^. J.params . J.arguments of
|
||||
Just (J.List (x : _)) -> case J.fromJSON x of
|
||||
J.Success uri -> Right uri
|
||||
_ -> Left $ "unable to parse uri argument to "
|
||||
<> show (request ^. J.params . J.command)
|
||||
_ -> Left $ "unable to parse uri argument to "
|
||||
<> show (request ^. J.params . J.command)
|
||||
|
||||
srcToRange :: Src -> J.Range
|
||||
srcToRange (Src (SourcePos _ x1 y1) (SourcePos _ x2 y2) _) =
|
||||
J.Range (J.Position (unPos x1 - 1) (unPos y1 - 1))
|
||||
(J.Position (unPos x2 - 1) (unPos y2 - 1))
|
||||
|
||||
executeAnnotateLet :: LSP.LspFuncs () -> J.ExecuteCommandRequest -> IO ()
|
||||
executeAnnotateLet lsp request = do
|
||||
LSP.logs "LSP Handler: executing AnnotateLet"
|
||||
err <- runExceptT (executeAnnotateLet' lsp request)
|
||||
case err of
|
||||
Left msg -> LSP.logs ("AnnotateLet failed: " ++ msg)
|
||||
_ -> return ()
|
||||
|
||||
executeAnnotateLet' :: LSP.LspFuncs () -> J.ExecuteCommandRequest -> ExceptT String IO ()
|
||||
executeAnnotateLet' lsp request = do
|
||||
args <- case request ^. J.params . J.arguments of
|
||||
Just (J.List (x : _)) -> return x
|
||||
_ -> throwE "arguments missing"
|
||||
(uri, line, col) <- case J.fromJSON args :: J.Result J.TextDocumentPositionParams of
|
||||
J.Success textDocPos -> return (textDocPos ^. J.textDocument . J.uri,
|
||||
textDocPos ^. J.position . J.line,
|
||||
textDocPos ^. J.position . J.character)
|
||||
_ -> throwE "failed to parse arguments"
|
||||
path <- case J.uriToFilePath uri of
|
||||
Just x -> return x
|
||||
_ -> throwE "unable to parse uri argument into file path"
|
||||
txt <- lift $ readUri lsp uri
|
||||
mexpr <- lift $ loadDhallExprSafe path txt
|
||||
expr <- case mexpr of
|
||||
Just e -> return e
|
||||
_ -> throwE "failed to parse dhall file"
|
||||
(src, txt') <- case annotateLet (line, col) expr of
|
||||
Right x -> return x
|
||||
Left err -> throwE err
|
||||
let edit = J.List [ J.TextEdit (srcToRange src) txt' ]
|
||||
lid <- lift $ LSP.getNextReqId lsp
|
||||
lift $ LSP.sendFunc lsp
|
||||
$ LSP.ReqApplyWorkspaceEdit
|
||||
$ LSP.fmServerApplyWorkspaceEditRequest lid
|
||||
$ J.ApplyWorkspaceEditParams
|
||||
$ J.WorkspaceEdit (Just (singleton uri edit)) Nothing
|
||||
|
|
@ -1,89 +0,0 @@
|
|||
{-| This module contains everything related to how the LSP server handles
|
||||
diagnostic messages. -}
|
||||
module Dhall.LSP.Handlers.Diagnostics
|
||||
( diagnosticsHandler, explainDiagnosis
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Utility as LSP
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
|
||||
import Data.Text ( Text )
|
||||
|
||||
import Dhall.LSP.Backend.Diagnostics
|
||||
import Dhall.LSP.Backend.Linting
|
||||
import Dhall.LSP.Util (readUri)
|
||||
|
||||
import Data.List ( find )
|
||||
import Data.Maybe ( mapMaybe )
|
||||
|
||||
-- | Called by @didOpenTextDocumentNotificationHandler@ and
|
||||
-- @didSaveTextDocumentNotificationHandler@.
|
||||
diagnosticsHandler :: LSP.LspFuncs () -> J.Uri -> IO ()
|
||||
diagnosticsHandler lsp uri = do
|
||||
LSP.logs $ "LSP Handler: processing diagnostics for " <> show uri
|
||||
let fileName = case J.uriToFilePath uri of
|
||||
Nothing -> fail "Failed to parse URI when computing diagnostics."
|
||||
Just path -> path
|
||||
txt <- readUri lsp uri
|
||||
let lintDiags = linterDiagnostics txt
|
||||
compDiags <- compilerDiagnostics fileName txt
|
||||
publishDiagnostics lsp uri (compDiags ++ lintDiags)
|
||||
|
||||
diagnosisToLSP :: Diagnosis -> J.Diagnostic
|
||||
diagnosisToLSP Diagnosis{..} = J.Diagnostic {..}
|
||||
where
|
||||
_range = case range of
|
||||
Just (Range (line1, col1) (line2, col2)) ->
|
||||
J.Range (J.Position line1 col1) (J.Position line2 col2)
|
||||
Nothing -> J.Range (J.Position 0 0) (J.Position 0 0)
|
||||
_severity = Just J.DsError
|
||||
_source = Just doctor
|
||||
_code = Nothing
|
||||
_message = diagnosis
|
||||
_relatedInformation = Nothing
|
||||
|
||||
compilerDiagnostics :: FilePath -> Text -> IO [J.Diagnostic]
|
||||
compilerDiagnostics path txt = do
|
||||
errors <- checkDhall path txt
|
||||
let diagnoses = concatMap (diagnose txt) errors
|
||||
return (map diagnosisToLSP diagnoses)
|
||||
|
||||
suggestionToDiagnostic :: Suggestion -> J.Diagnostic
|
||||
suggestionToDiagnostic Suggestion {..} = J.Diagnostic {..}
|
||||
where
|
||||
_range = case range of
|
||||
Range (line1, col1) (line2, col2) ->
|
||||
J.Range (J.Position line1 col1) (J.Position line2 col2)
|
||||
_severity = Just J.DsHint
|
||||
_source = Just "Dhall.Lint"
|
||||
_code = Nothing
|
||||
_message = suggestion
|
||||
_relatedInformation = Nothing
|
||||
|
||||
explainDiagnosis :: FilePath -> Text -> Position -> IO (Maybe Diagnosis)
|
||||
explainDiagnosis path txt pos = do
|
||||
errors <- checkDhall path txt
|
||||
let explanations = mapMaybe (explain txt) errors
|
||||
return $ find (isHovered pos) explanations
|
||||
|
||||
isHovered :: Position -> Diagnosis -> Bool
|
||||
isHovered _ (Diagnosis _ Nothing _) = False
|
||||
isHovered pos (Diagnosis _ (Just (Range left right)) _) =
|
||||
left <= pos && pos <= right
|
||||
|
||||
-- | Compute the list of possible improvements, as would be carried out by
|
||||
-- @Dhall.Lint@.
|
||||
linterDiagnostics :: Text -> [J.Diagnostic]
|
||||
linterDiagnostics = map suggestionToDiagnostic . suggest
|
||||
|
||||
-- | Publish diagnostics for a given file. Overwrites any existing diagnostics
|
||||
-- on the client side! In order to clear the diagnostics for a given file simply
|
||||
-- pass the empty list [].
|
||||
publishDiagnostics :: LSP.LspFuncs () -> J.Uri -> [J.Diagnostic] -> IO ()
|
||||
publishDiagnostics lsp uri diags =
|
||||
LSP.sendFunc lsp $ LSP.NotPublishDiagnostics
|
||||
$ J.NotificationMessage "2.0" J.TextDocumentPublishDiagnostics
|
||||
$ J.PublishDiagnosticsParams uri (J.List diags)
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
module Dhall.LSP.Handlers.DocumentFormatting(formatDocument) where
|
||||
|
||||
|
||||
|
||||
import qualified Dhall.LSP.Backend.Formatting as Formatting
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Utility as LSP.Utility
|
||||
|
||||
import qualified Data.Text
|
||||
import qualified Data.Text.IO
|
||||
import Control.Monad.Trans (lift)
|
||||
import Control.Monad.Reader (ReaderT)
|
||||
|
||||
-- TODO: implement tabSize and spaces/tabs options
|
||||
-- * Note: any formatting errors would be swallowed. I think this is fine in this case, but generally we'd like to send user a notification
|
||||
-- (e.g. the error occurred in the formatter itself, and user requests format constantly and nothing happens)
|
||||
formatDocument :: J.Uri -> Int -> Bool -> ReaderT (LSP.Core.LspFuncs ()) IO (J.List J.TextEdit)
|
||||
formatDocument fileUri _tabSize _insertSpaces = do
|
||||
let
|
||||
filePath = maybe (error "can't convert uri to file path") id $ J.uriToFilePath fileUri -- !FIXME: handle non-file uris
|
||||
txt <- lift $ Data.Text.IO.readFile filePath
|
||||
case Formatting.formatDocument txt of
|
||||
(Right formatted) -> let
|
||||
numLines = Data.Text.length txt
|
||||
range = J.Range (J.Position 0 0) (J.Position numLines 0)
|
||||
in pure $ J.List [J.TextEdit range formatted]
|
||||
(Left err) -> do
|
||||
lift $ LSP.Utility.logs $ "Error while formatting the document " <> show err
|
||||
pure (J.List [])
|
||||
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
module Dhall.LSP.Handlers.Hover (hoverHandler) where
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Utility as LSP
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types.Lens as J
|
||||
|
||||
import Dhall.Core (pretty)
|
||||
|
||||
import Dhall.LSP.Backend.Dhall
|
||||
import Dhall.LSP.Backend.Diagnostics
|
||||
import Dhall.LSP.Handlers.Diagnostics (explainDiagnosis)
|
||||
import Dhall.LSP.Backend.Typing
|
||||
import Dhall.LSP.Util (readUri)
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import qualified Network.URI.Encode as URI
|
||||
import qualified Data.Text as Text
|
||||
|
||||
-- | This is a prototype implementation. We should avoid recomputing the
|
||||
-- diagnostics each time.
|
||||
hoverHandler :: LSP.LspFuncs () -> J.HoverRequest -> IO ()
|
||||
hoverHandler lsp request = do
|
||||
LSP.logs "LSP Handler: processing HoverRequest"
|
||||
let uri = request ^. J.params . J.textDocument . J.uri
|
||||
(J.Position line col) = request ^. (J.params . J.position)
|
||||
pos = (line, col)
|
||||
fileName = case J.uriToFilePath uri of
|
||||
Nothing -> fail "Failed to parse URI in ReqHover."
|
||||
Just path -> path
|
||||
txt <- readUri lsp uri
|
||||
-- Explain takes priority
|
||||
mexplain <- explainDiagnosis fileName txt (line, col)
|
||||
case mexplain of
|
||||
Just explanation -> LSP.sendFunc lsp
|
||||
$ LSP.RspHover
|
||||
$ LSP.makeResponseMessage
|
||||
request (hoverFromDiagnosis explanation)
|
||||
Nothing -> do -- infer type
|
||||
mexpr <- loadDhallExprSafe fileName txt
|
||||
case mexpr of
|
||||
Nothing -> LSP.sendFunc lsp $ LSP.RspHover
|
||||
$ LSP.makeResponseMessage request Nothing
|
||||
Just expr ->
|
||||
case typeAt pos expr of
|
||||
Right typ ->
|
||||
let _range = fmap (rangeToJSON . sanitiseRange txt . rangeFromDhall)
|
||||
(srcAt pos expr)
|
||||
_contents = J.List [J.PlainString (pretty typ)]
|
||||
hover = J.Hover{..}
|
||||
in LSP.sendFunc lsp $ LSP.RspHover
|
||||
$ LSP.makeResponseMessage request (Just hover)
|
||||
_ -> LSP.sendFunc lsp $ LSP.RspHover
|
||||
$ LSP.makeResponseMessage request Nothing
|
||||
|
||||
|
||||
rangeToJSON :: Range -> J.Range
|
||||
rangeToJSON (Range (x1,y1) (x2,y2)) = J.Range (J.Position x1 y1) (J.Position x2 y2)
|
||||
|
||||
hoverFromDiagnosis :: Diagnosis -> Maybe J.Hover
|
||||
hoverFromDiagnosis (Diagnosis _ Nothing _) = Nothing
|
||||
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = Just
|
||||
J.Hover { .. }
|
||||
where
|
||||
_range =
|
||||
Just $ J.Range (uncurry J.Position left) (uncurry J.Position right)
|
||||
encodedDiag = URI.encode (Text.unpack diagnosis)
|
||||
command =
|
||||
"[Explain error](dhall-explain:?" <> Text.pack encodedDiag <> " )"
|
||||
_contents = J.List [J.PlainString command]
|
||||
|
|
@ -1,41 +1,38 @@
|
|||
|
||||
{-| This is the entry point for the LSP server. All calls are delegated to the haskell-lsp library
|
||||
which does the heavy lifting.
|
||||
-}
|
||||
{-| This is the entry point for the LSP server. -}
|
||||
module Dhall.LSP.Server(run) where
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Concurrent.MVar
|
||||
import Data.Default
|
||||
import qualified Language.Haskell.LSP.Control as LSP.Control
|
||||
import qualified Language.Haskell.LSP.Core as LSP.Core
|
||||
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified System.Log.Logger
|
||||
import GHC.Conc (atomically)
|
||||
|
||||
import qualified Dhall.LSP.Handlers as Handlers
|
||||
import qualified Dhall.LSP.Handlers.Command as Handlers
|
||||
import qualified Dhall.LSP.Handlers.Hover as Handlers
|
||||
import Dhall.LSP.State
|
||||
import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler,
|
||||
didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler,
|
||||
executeCommandHandler, documentFormattingHandler)
|
||||
|
||||
-- | The main entry point for the LSP server.
|
||||
run :: Maybe FilePath -> IO ()
|
||||
run mlog = do
|
||||
setupLogger mlog
|
||||
vlsp <- newTVarIO Nothing
|
||||
_ <- LSP.Control.run (makeConfig, initCallback vlsp) (lspHandlers vlsp)
|
||||
state <- newEmptyMVar
|
||||
_ <- LSP.Control.run (makeConfig, initCallback state) (lspHandlers state)
|
||||
lspOptions Nothing
|
||||
return ()
|
||||
where
|
||||
-- Callback that is called when the LSP server is started; makes the lsp
|
||||
-- state (LspFuncs) available to the message handlers through the vlsp TVar.
|
||||
-- state (LspFuncs) available to the message handlers through the vlsp MVar.
|
||||
initCallback
|
||||
:: TVar (Maybe (LSP.Core.LspFuncs ()))
|
||||
:: MVar ServerState
|
||||
-> LSP.Core.LspFuncs ()
|
||||
-> IO (Maybe J.ResponseError)
|
||||
initCallback vlsp lsp = do
|
||||
atomically $ writeTVar vlsp (Just lsp)
|
||||
initCallback state lsp = do
|
||||
putMVar state (initialState lsp)
|
||||
return Nothing
|
||||
|
||||
-- Interpret DidChangeConfigurationNotification; pointless at the moment
|
||||
|
|
@ -75,35 +72,19 @@ lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
|
|||
-- around this peculiarity.
|
||||
Just (J.ExecuteCommandOptions
|
||||
(J.List ["dhall.server.lint",
|
||||
"dhall.server.toJSON",
|
||||
"dhall.server.annotateLet"]))
|
||||
}
|
||||
|
||||
lspHandlers :: TVar (Maybe (LSP.Core.LspFuncs ())) -> LSP.Core.Handlers
|
||||
lspHandlers lsp
|
||||
= def { LSP.Core.initializedHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.hoverHandler = Just $ wrapHandler lsp Handlers.hoverHandler
|
||||
, LSP.Core.didOpenTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.didOpenTextDocumentNotificationHandler
|
||||
, LSP.Core.didChangeTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.didSaveTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.didSaveTextDocumentNotificationHandler
|
||||
, LSP.Core.didCloseTextDocumentNotificationHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.cancelNotificationHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.responseHandler = Just $ wrapHandler lsp Handlers.nullHandler
|
||||
, LSP.Core.executeCommandHandler = Just $ wrapHandler lsp Handlers.executeCommandHandler
|
||||
, LSP.Core.documentFormattingHandler = Just $ wrapHandler lsp Handlers.documentFormattingHandler
|
||||
lspHandlers :: MVar ServerState -> LSP.Core.Handlers
|
||||
lspHandlers state
|
||||
= def { LSP.Core.initializedHandler = Just $ wrapHandler state nullHandler
|
||||
, LSP.Core.hoverHandler = Just $ wrapHandler state hoverHandler
|
||||
, LSP.Core.didOpenTextDocumentNotificationHandler = Just $ wrapHandler state didOpenTextDocumentNotificationHandler
|
||||
, LSP.Core.didChangeTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler
|
||||
, LSP.Core.didSaveTextDocumentNotificationHandler = Just $ wrapHandler state didSaveTextDocumentNotificationHandler
|
||||
, LSP.Core.didCloseTextDocumentNotificationHandler = Just $ wrapHandler state nullHandler
|
||||
, LSP.Core.cancelNotificationHandler = Just $ wrapHandler state nullHandler
|
||||
, LSP.Core.responseHandler = Just $ wrapHandler state nullHandler
|
||||
, LSP.Core.executeCommandHandler = Just $ wrapHandler state executeCommandHandler
|
||||
, LSP.Core.documentFormattingHandler = Just $ wrapHandler state documentFormattingHandler
|
||||
}
|
||||
|
||||
-- Workaround to make our single-threaded LSP fit dhall-lsp's API, which
|
||||
-- expects a multi-threaded implementation.
|
||||
wrapHandler
|
||||
:: TVar (Maybe (LSP.Core.LspFuncs ()))
|
||||
-> (LSP.Core.LspFuncs () -> a -> IO ())
|
||||
-> a
|
||||
-> IO ()
|
||||
wrapHandler vlsp handle message = do
|
||||
mlsp <- readTVarIO vlsp
|
||||
case mlsp of
|
||||
Just lsp -> handle lsp message
|
||||
Nothing ->
|
||||
fail "A handler was called before the LSP was initialized properly.\
|
||||
\ This should never happen."
|
||||
|
|
|
|||
|
|
@ -0,0 +1,52 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Dhall.LSP.State where
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.Messages as LSP
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
|
||||
import Control.Lens.TH (makeLenses)
|
||||
import Lens.Family (LensLike')
|
||||
import Data.Map.Strict (Map, empty)
|
||||
import Data.Dynamic (Dynamic)
|
||||
import Dhall.LSP.Backend.Dhall (DhallError, Cache, emptyCache)
|
||||
import Data.Text (Text)
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
|
||||
-- Inside a handler we have access to the ServerState. The exception layer
|
||||
-- allows us to fail gracefully, displaying a message to the user via the
|
||||
-- "ShowMessage" mechanism of the lsp standard.
|
||||
type HandlerM = ExceptT (Severity, Text) (StateT ServerState IO)
|
||||
|
||||
data Severity = Error
|
||||
-- ^ Error displayed to the user.
|
||||
| Warning
|
||||
-- ^ Warning displayed to the user.
|
||||
| Info
|
||||
-- ^ Information displayed to the user.
|
||||
| Log
|
||||
-- ^ Log message, not displayed by default.
|
||||
|
||||
data ServerState = ServerState
|
||||
{ _importCache :: Cache -- ^ The dhall import cache
|
||||
, _errors :: Map J.Uri DhallError -- ^ Map from dhall files to their errors
|
||||
, _httpManager :: Maybe Dynamic
|
||||
-- ^ The http manager used by dhall's import infrastructure
|
||||
, _lspFuncs :: LSP.LspFuncs ()
|
||||
-- ^ Access to the lsp functions supplied by haskell-lsp
|
||||
}
|
||||
|
||||
makeLenses ''ServerState
|
||||
|
||||
sendFunc :: Functor f =>
|
||||
LensLike' f (LSP.LspFuncs ()) (LSP.FromServerMessage -> IO ())
|
||||
sendFunc k s = fmap (\x -> s {LSP.sendFunc = x}) (k (LSP.sendFunc s))
|
||||
|
||||
initialState :: LSP.LspFuncs () -> ServerState
|
||||
initialState lsp = ServerState {..}
|
||||
where
|
||||
_importCache = emptyCache
|
||||
_errors = empty
|
||||
_httpManager = Nothing
|
||||
_lspFuncs = lsp
|
||||
|
|
@ -3,16 +3,10 @@
|
|||
module Dhall.LSP.Util (
|
||||
tshow,
|
||||
lines',
|
||||
readUri,
|
||||
rightToMaybe,
|
||||
unlines'
|
||||
) where
|
||||
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.VFS as LSP
|
||||
import qualified Language.Haskell.LSP.Types as J
|
||||
import qualified Yi.Rope as Rope
|
||||
|
||||
import Data.Text
|
||||
import Data.List.NonEmpty
|
||||
|
||||
|
|
@ -34,14 +28,6 @@ lines' text =
|
|||
unlines' :: [Text] -> Text
|
||||
unlines' = intercalate "\n"
|
||||
|
||||
-- | A helper function to query haskell-lsp's VFS.
|
||||
readUri :: LSP.LspFuncs () -> J.Uri -> IO Text
|
||||
readUri lsp uri = do
|
||||
asd <- LSP.getVirtualFileFunc lsp uri
|
||||
case asd of
|
||||
Just (LSP.VirtualFile _ rope) -> return (Rope.toText rope)
|
||||
Nothing -> fail $ "Could not find " <> show uri <> " in VFS."
|
||||
|
||||
rightToMaybe :: Either a b -> Maybe b
|
||||
rightToMaybe (Right b) = Just b
|
||||
rightToMaybe (Left _) = Nothing
|
||||
|
|
|
|||
Loading…
Reference in New Issue