dhall-lsp-server: Type on hover (#1008)
* Type on Hover 1/2: Backend Adds a function typeAt that, given an annotated expression and a text position finds the type of the subexpression at that position. * Type on Hover 2/2: Frontend Exposes the new type-on-hover functionality as part of the hover handler. * Simplify explainDiagnosis As suggested by @Gabriel439 * Simplify `inside` Adressing @Gabriel439's comment. * Simplify typeAt' by assuming well-typedness * Simply srcAt Use choice operator `<|>` instead of case distinction
This commit is contained in:
parent
b001a61a02
commit
66833cbfa5
|
@ -25,6 +25,7 @@ library
|
||||||
Dhall.LSP.Backend.Formatting
|
Dhall.LSP.Backend.Formatting
|
||||||
Dhall.LSP.Backend.Linting
|
Dhall.LSP.Backend.Linting
|
||||||
Dhall.LSP.Backend.ToJSON
|
Dhall.LSP.Backend.ToJSON
|
||||||
|
Dhall.LSP.Backend.Typing
|
||||||
Dhall.LSP.Handlers
|
Dhall.LSP.Handlers
|
||||||
Dhall.LSP.Handlers.Command
|
Dhall.LSP.Handlers.Command
|
||||||
Dhall.LSP.Handlers.Diagnostics
|
Dhall.LSP.Handlers.Diagnostics
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
module Dhall.LSP.Backend.Dhall where
|
module Dhall.LSP.Backend.Dhall where
|
||||||
|
|
||||||
import Dhall.Parser (Src(..))
|
import Dhall.Import (loadWith, emptyStatus)
|
||||||
|
import Dhall.Parser (Src, exprFromText)
|
||||||
import Dhall.TypeCheck (X)
|
import Dhall.TypeCheck (X)
|
||||||
import Dhall.Core (Expr)
|
import Dhall.Core (Expr)
|
||||||
import Dhall
|
import Dhall
|
||||||
|
@ -10,6 +11,7 @@ import Data.Text (Text)
|
||||||
import System.FilePath (splitFileName)
|
import System.FilePath (splitFileName)
|
||||||
import Lens.Family (set)
|
import Lens.Family (set)
|
||||||
import Control.Exception (handle, SomeException)
|
import Control.Exception (handle, SomeException)
|
||||||
|
import Control.Monad.Trans.State.Strict (evalStateT)
|
||||||
|
|
||||||
runDhall :: FilePath -> Text -> IO (Expr Src X)
|
runDhall :: FilePath -> Text -> IO (Expr Src X)
|
||||||
runDhall path = inputExprWithSettings dhallparams
|
runDhall path = inputExprWithSettings dhallparams
|
||||||
|
@ -21,3 +23,12 @@ runDhall path = inputExprWithSettings dhallparams
|
||||||
runDhallSafe :: FilePath -> Text -> IO (Maybe (Expr Src X))
|
runDhallSafe :: FilePath -> Text -> IO (Maybe (Expr Src X))
|
||||||
runDhallSafe path text = handle (\(_ :: SomeException) -> return Nothing)
|
runDhallSafe path text = handle (\(_ :: SomeException) -> return Nothing)
|
||||||
(Just <$> runDhall path text)
|
(Just <$> runDhall path text)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
|
@ -4,11 +4,15 @@ module Dhall.LSP.Backend.Diagnostics
|
||||||
( DhallException
|
( DhallException
|
||||||
, checkDhall
|
, checkDhall
|
||||||
, diagnose
|
, diagnose
|
||||||
, explain
|
|
||||||
, rangeFromDhall
|
|
||||||
, Position
|
|
||||||
, Range(..)
|
|
||||||
, Diagnosis(..)
|
, Diagnosis(..)
|
||||||
|
, explain
|
||||||
|
, offsetToPosition
|
||||||
|
, Position
|
||||||
|
, positionFromMegaparsec
|
||||||
|
, positionToOffset
|
||||||
|
, Range(..)
|
||||||
|
, rangeFromDhall
|
||||||
|
, sanitiseRange
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
75
dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs
Normal file
75
dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs
Normal file
|
@ -0,0 +1,75 @@
|
||||||
|
module Dhall.LSP.Backend.Typing (typeAt, srcAt) where
|
||||||
|
|
||||||
|
import Dhall.Context (Context, insert, empty)
|
||||||
|
import Dhall.Core (Expr(..), Binding(..), subExpressions, normalize, shift, Var(..))
|
||||||
|
import Dhall.TypeCheck (typeWithA, X(..), TypeError(..))
|
||||||
|
import Dhall.Parser (Src(..))
|
||||||
|
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
import Control.Lens (toListOf)
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import Control.Applicative ((<|>))
|
||||||
|
|
||||||
|
import Dhall.LSP.Backend.Diagnostics (Position, positionFromMegaparsec, offsetToPosition)
|
||||||
|
|
||||||
|
-- | Find the type of the subexpression at the given position. Assumes that the
|
||||||
|
-- input expression is well-typed.
|
||||||
|
typeAt :: Position -> Expr Src X -> Maybe (Expr Src X)
|
||||||
|
typeAt pos expr = case typeAt' pos empty expr of
|
||||||
|
Right typ -> Just typ
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
typeAt' :: Position -> Context (Expr Src X) -> Expr Src X -> Either (TypeError Src X) (Expr Src X)
|
||||||
|
-- unfold lets to make things simpler
|
||||||
|
-- need to match on outer Note to recover the range
|
||||||
|
typeAt' pos ctx (Note src (Let (b :| (b' : bs)) e)) =
|
||||||
|
typeAt' pos ctx (Note src (Let (b :| []) (Note src (Let (b' :| bs) e))))
|
||||||
|
|
||||||
|
-- only handle singleton lets explicitly
|
||||||
|
typeAt' pos ctx (Let (Binding x _ a :| []) (Note src e)) | pos `inside` src = do
|
||||||
|
_A <- typeWithA absurd ctx a
|
||||||
|
let ctx' = fmap (shift 1 (V x 0)) (insert x _A ctx)
|
||||||
|
typeAt' pos ctx' e
|
||||||
|
|
||||||
|
typeAt' pos ctx (Lam x _A (Note src b)) | pos `inside` src = do
|
||||||
|
let _A' = Dhall.Core.normalize _A
|
||||||
|
ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx)
|
||||||
|
typeAt' pos ctx' b
|
||||||
|
|
||||||
|
typeAt' pos ctx (Pi x _A (Note src _B)) | pos `inside` src = do
|
||||||
|
let _A' = Dhall.Core.normalize _A
|
||||||
|
ctx' = fmap (shift 1 (V x 0)) (insert x _A' ctx)
|
||||||
|
typeAt' pos ctx' _B
|
||||||
|
|
||||||
|
-- need to catch Notes since the catch-all would remove two layers at once
|
||||||
|
typeAt' pos ctx (Note _ expr) = typeAt' pos ctx expr
|
||||||
|
|
||||||
|
-- catch-all
|
||||||
|
typeAt' pos ctx expr = do
|
||||||
|
let subExprs = toListOf subExpressions expr
|
||||||
|
case [ e | (Note src e) <- subExprs, pos `inside` src ] of
|
||||||
|
[] -> typeWithA absurd ctx expr -- return type of whole subexpression
|
||||||
|
(t:_) -> typeAt' pos ctx t -- continue with leaf-expression
|
||||||
|
|
||||||
|
|
||||||
|
-- | Find the smallest Src annotation containing the given position.
|
||||||
|
srcAt :: Position -> Expr Src X -> Maybe Src
|
||||||
|
srcAt pos (Note src expr) = srcAt pos expr <|> Just src
|
||||||
|
srcAt pos expr =
|
||||||
|
let subExprs = toListOf subExpressions expr
|
||||||
|
in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of
|
||||||
|
[] -> Nothing
|
||||||
|
((src, e) : _) -> srcAt pos e <|> Just src
|
||||||
|
|
||||||
|
|
||||||
|
-- Check if range lies completely inside a given subexpression.
|
||||||
|
-- This version takes trailing whitespace into account
|
||||||
|
-- (c.f. `sanitiseRange` from Backend.Diangostics).
|
||||||
|
inside :: Position -> Src -> Bool
|
||||||
|
inside pos (Src left _right txt) =
|
||||||
|
let (x1,y1) = positionFromMegaparsec left
|
||||||
|
txt' = Text.stripEnd txt
|
||||||
|
(dx2,dy2) = (offsetToPosition txt . Text.length) txt'
|
||||||
|
(x2,y2) | dx2 == 0 = (x1, y1 + dy2)
|
||||||
|
| otherwise = (x1 + dx2, dy2)
|
||||||
|
in (x1,y1) <= pos && pos < (x2,y2)
|
|
@ -1,7 +1,7 @@
|
||||||
{-| This module contains everything related to how the LSP server handles
|
{-| This module contains everything related to how the LSP server handles
|
||||||
diagnostic messages. -}
|
diagnostic messages. -}
|
||||||
module Dhall.LSP.Handlers.Diagnostics
|
module Dhall.LSP.Handlers.Diagnostics
|
||||||
( diagnosticsHandler
|
( diagnosticsHandler, explainDiagnosis
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -16,6 +16,8 @@ import Dhall.LSP.Backend.Diagnostics
|
||||||
import Dhall.LSP.Backend.Linting
|
import Dhall.LSP.Backend.Linting
|
||||||
import Dhall.LSP.Util (readUri)
|
import Dhall.LSP.Util (readUri)
|
||||||
|
|
||||||
|
import Data.List ( find )
|
||||||
|
import Data.Maybe ( mapMaybe )
|
||||||
|
|
||||||
-- | Called by @didOpenTextDocumentNotificationHandler@ and
|
-- | Called by @didOpenTextDocumentNotificationHandler@ and
|
||||||
-- @didSaveTextDocumentNotificationHandler@.
|
-- @didSaveTextDocumentNotificationHandler@.
|
||||||
|
@ -61,6 +63,17 @@ suggestionToDiagnostic Suggestion {..} = J.Diagnostic {..}
|
||||||
_message = suggestion
|
_message = suggestion
|
||||||
_relatedInformation = Nothing
|
_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
|
-- | Compute the list of possible improvements, as would be carried out by
|
||||||
-- @Dhall.Lint@.
|
-- @Dhall.Lint@.
|
||||||
linterDiagnostics :: Text -> [J.Diagnostic]
|
linterDiagnostics :: Text -> [J.Diagnostic]
|
||||||
|
|
|
@ -7,39 +7,58 @@ import qualified Language.Haskell.LSP.Utility as LSP
|
||||||
import qualified Language.Haskell.LSP.Types as J
|
import qualified Language.Haskell.LSP.Types as J
|
||||||
import qualified Language.Haskell.LSP.Types.Lens 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.Backend.Diagnostics
|
||||||
|
import Dhall.LSP.Handlers.Diagnostics (explainDiagnosis)
|
||||||
|
import Dhall.LSP.Backend.Typing
|
||||||
import Dhall.LSP.Util (readUri)
|
import Dhall.LSP.Util (readUri)
|
||||||
|
|
||||||
import Control.Lens ((^.))
|
import Control.Lens ((^.))
|
||||||
import qualified Network.URI.Encode as URI
|
import qualified Network.URI.Encode as URI
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Data.Maybe (mapMaybe)
|
|
||||||
|
|
||||||
-- | This is a prototype implementation. We should avoid recomputing the
|
-- | This is a prototype implementation. We should avoid recomputing the
|
||||||
-- diagnostics each time.
|
-- diagnostics each time.
|
||||||
hoverHandler :: LSP.LspFuncs () -> J.HoverRequest -> IO ()
|
hoverHandler :: LSP.LspFuncs () -> J.HoverRequest -> IO ()
|
||||||
hoverHandler lsp request = do
|
hoverHandler lsp request = do
|
||||||
LSP.logs "LSP Handler: processing HoverRequest"
|
LSP.logs "LSP Handler: processing HoverRequest"
|
||||||
let
|
let uri = request ^. J.params . J.textDocument . J.uri
|
||||||
uri = request ^. J.params . J.textDocument . J.uri
|
|
||||||
(J.Position line col) = request ^. (J.params . J.position)
|
(J.Position line col) = request ^. (J.params . J.position)
|
||||||
|
pos = (line, col)
|
||||||
fileName = case J.uriToFilePath uri of
|
fileName = case J.uriToFilePath uri of
|
||||||
Nothing -> fail "Failed to parse URI in ReqHover."
|
Nothing -> fail "Failed to parse URI in ReqHover."
|
||||||
Just path -> path
|
Just path -> path
|
||||||
txt <- readUri lsp uri
|
txt <- readUri lsp uri
|
||||||
errors <- checkDhall fileName txt
|
-- Explain takes priority
|
||||||
let
|
mexplain <- explainDiagnosis fileName txt (line, col)
|
||||||
explanations = mapMaybe (explain txt) errors
|
case mexplain of
|
||||||
isHovered :: Diagnosis -> Bool
|
Just explanation -> LSP.sendFunc lsp
|
||||||
isHovered (Diagnosis _ Nothing _) = False
|
$ LSP.RspHover
|
||||||
isHovered (Diagnosis _ (Just (Range left right)) _) =
|
$ LSP.makeResponseMessage
|
||||||
left <= (line, col) && (line, col) <= right
|
request (hoverFromDiagnosis explanation)
|
||||||
hover = case filter isHovered explanations of
|
Nothing -> do -- infer type
|
||||||
[] -> Nothing
|
mexpr <- loadDhallExprSafe fileName txt
|
||||||
(diag : _) -> hoverFromDiagnosis diag
|
case mexpr of
|
||||||
LSP.sendFunc lsp $ LSP.RspHover $ LSP.makeResponseMessage request hover
|
Nothing -> LSP.sendFunc lsp $ LSP.RspHover
|
||||||
|
$ LSP.makeResponseMessage request Nothing
|
||||||
|
Just expr ->
|
||||||
|
case typeAt pos expr of
|
||||||
|
Just 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)
|
||||||
|
Nothing -> 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 -> Maybe J.Hover
|
||||||
hoverFromDiagnosis (Diagnosis _ Nothing _) = Nothing
|
hoverFromDiagnosis (Diagnosis _ Nothing _) = Nothing
|
||||||
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = Just
|
hoverFromDiagnosis (Diagnosis _ (Just (Range left right)) diagnosis) = Just
|
||||||
|
|
Loading…
Reference in New Issue
Block a user