dhall-lsp-server: Fix hovering in presence of nested lets (#1537)
* Fix hacked-together parsers Back when we changed the linter to preserve let comments we made whitespace parsing explicit (previously combinators swallowed any trailing whitespace), but we forgot to update the hacked-together parsers used by the LSP server. As a result, various convenience features broke, but that's easy enough to fix. * Fix 'annotate lets' and 'type on hover' features Both features only work as intended if as much of the Dhall code as possible is wrapped in Note annotations, since we use that to figure out where the user was pointing. Since the removal of explicit multi-lets in the syntax the parser no longer wraps immediately nested lets (i.e. multilets) in Notes, which means we need to split them manually (like we used to). * Fix hovering test Now the behaviour expected by the test matches what we would want in reality.
This commit is contained in:
parent
6c68f8206d
commit
619788f795
|
@ -24,7 +24,6 @@ import Control.Applicative (optional, (<|>))
|
||||||
import qualified Text.Megaparsec as Megaparsec
|
import qualified Text.Megaparsec as Megaparsec
|
||||||
import Text.Megaparsec (SourcePos(..))
|
import Text.Megaparsec (SourcePos(..))
|
||||||
|
|
||||||
|
|
||||||
-- | Parse the outermost binding in a Src descriptor of a let-block and return
|
-- | Parse the outermost binding in a Src descriptor of a let-block and return
|
||||||
-- the rest. Ex. on input `let a = 0 let b = a in b` parses `let a = 0 ` and
|
-- the rest. Ex. on input `let a = 0 let b = a in b` parses `let a = 0 ` and
|
||||||
-- returns the Src descriptor containing `let b = a in b`.
|
-- returns the Src descriptor containing `let b = a in b`.
|
||||||
|
@ -33,13 +32,20 @@ getLetInner (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetInnerOff
|
||||||
where parseLetInnerOffset = do
|
where parseLetInnerOffset = do
|
||||||
setSourcePos left
|
setSourcePos left
|
||||||
_let
|
_let
|
||||||
|
nonemptyWhitespace
|
||||||
_ <- label
|
_ <- label
|
||||||
|
whitespace
|
||||||
_ <- optional (do
|
_ <- optional (do
|
||||||
_ <- _colon
|
_ <- _colon
|
||||||
expr)
|
nonemptyWhitespace
|
||||||
|
_ <- expr
|
||||||
|
whitespace)
|
||||||
_equal
|
_equal
|
||||||
|
whitespace
|
||||||
_ <- expr
|
_ <- expr
|
||||||
|
whitespace
|
||||||
_ <- optional _in
|
_ <- optional _in
|
||||||
|
whitespace
|
||||||
begin <- getSourcePos
|
begin <- getSourcePos
|
||||||
tokens <- Megaparsec.takeRest
|
tokens <- Megaparsec.takeRest
|
||||||
end <- getSourcePos
|
end <- getSourcePos
|
||||||
|
@ -53,11 +59,15 @@ getLetAnnot (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetAnnot) t
|
||||||
where parseLetAnnot = do
|
where parseLetAnnot = do
|
||||||
setSourcePos left
|
setSourcePos left
|
||||||
_let
|
_let
|
||||||
|
nonemptyWhitespace
|
||||||
_ <- label
|
_ <- label
|
||||||
|
whitespace
|
||||||
begin <- getSourcePos
|
begin <- getSourcePos
|
||||||
(tokens, _) <- Megaparsec.match $ optional (do
|
(tokens, _) <- Megaparsec.match $ optional (do
|
||||||
_ <- _colon
|
_ <- _colon
|
||||||
expr)
|
nonemptyWhitespace
|
||||||
|
_ <- expr
|
||||||
|
whitespace)
|
||||||
end <- getSourcePos
|
end <- getSourcePos
|
||||||
_ <- Megaparsec.takeRest
|
_ <- Megaparsec.takeRest
|
||||||
return (Src begin end tokens)
|
return (Src begin end tokens)
|
||||||
|
@ -73,7 +83,7 @@ getLetIdentifier src@(Src left _ text) =
|
||||||
where parseLetIdentifier = do
|
where parseLetIdentifier = do
|
||||||
setSourcePos left
|
setSourcePos left
|
||||||
_let
|
_let
|
||||||
whitespace
|
nonemptyWhitespace
|
||||||
begin <- getSourcePos
|
begin <- getSourcePos
|
||||||
(tokens, _) <- Megaparsec.match label
|
(tokens, _) <- Megaparsec.match label
|
||||||
end <- getSourcePos
|
end <- getSourcePos
|
||||||
|
|
|
@ -10,7 +10,7 @@ import Control.Applicative ((<|>))
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.Void (absurd, Void)
|
import Data.Void (absurd, Void)
|
||||||
|
|
||||||
import Dhall.LSP.Backend.Parsing (getLetAnnot, getLetIdentifier,
|
import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot, getLetIdentifier,
|
||||||
getLamIdentifier, getForallIdentifier)
|
getLamIdentifier, getForallIdentifier)
|
||||||
import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall)
|
import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall)
|
||||||
import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
|
import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
|
||||||
|
@ -20,7 +20,10 @@ import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped)
|
||||||
-- that subexpression if possible.
|
-- that subexpression if possible.
|
||||||
typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src Void)
|
typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src Void)
|
||||||
typeAt pos expr = do
|
typeAt pos expr = do
|
||||||
let expr' = fromWellTyped expr
|
expr' <- case splitMultiLetSrc (fromWellTyped expr) of
|
||||||
|
Just e -> return e
|
||||||
|
Nothing -> Left "The impossible happened: failed to split let\
|
||||||
|
\ blocks when preprocessing for typeAt'."
|
||||||
(mSrc, typ) <- first show $ typeAt' pos empty expr'
|
(mSrc, typ) <- first show $ typeAt' pos empty expr'
|
||||||
case mSrc of
|
case mSrc of
|
||||||
Just src -> return (Just src, normalize typ)
|
Just src -> return (Just src, normalize typ)
|
||||||
|
@ -42,7 +45,6 @@ typeAt' pos _ctx (Note src (Pi _ _A _)) | Just src' <- getForallIdentifier src
|
||||||
, pos `inside` src' =
|
, pos `inside` src' =
|
||||||
return (Just src', _A)
|
return (Just src', _A)
|
||||||
|
|
||||||
-- the input only contains singleton lets
|
|
||||||
typeAt' pos ctx (Let (Binding { variable = x, value = a }) e@(Note src _)) | pos `inside` src = do
|
typeAt' pos ctx (Let (Binding { variable = x, value = a }) e@(Note src _)) | pos `inside` src = do
|
||||||
_ <- typeWithA absurd ctx a
|
_ <- typeWithA absurd ctx a
|
||||||
let a' = shift 1 (V x 0) (normalize a)
|
let a' = shift 1 (V x 0) (normalize a)
|
||||||
|
@ -72,12 +74,16 @@ typeAt' pos ctx expr = do
|
||||||
|
|
||||||
-- | Find the smallest Note-wrapped expression at the given position.
|
-- | Find the smallest Note-wrapped expression at the given position.
|
||||||
exprAt :: Position -> Expr Src a -> Maybe (Expr Src a)
|
exprAt :: Position -> Expr Src a -> Maybe (Expr Src a)
|
||||||
exprAt pos e@(Note _ expr) = exprAt pos expr <|> Just e
|
exprAt pos e = do e' <- splitMultiLetSrc e
|
||||||
exprAt pos expr =
|
exprAt' pos e'
|
||||||
|
|
||||||
|
exprAt' :: Position -> Expr Src a -> Maybe (Expr Src a)
|
||||||
|
exprAt' pos e@(Note _ expr) = exprAt pos expr <|> Just e
|
||||||
|
exprAt' pos expr =
|
||||||
let subExprs = toListOf subExpressions expr
|
let subExprs = toListOf subExpressions expr
|
||||||
in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of
|
in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of
|
||||||
[] -> Nothing
|
[] -> Nothing
|
||||||
((src,e) : _) -> exprAt pos e <|> Just (Note src e)
|
((src,e) : _) -> exprAt' pos e <|> Just (Note src e)
|
||||||
|
|
||||||
|
|
||||||
-- | Find the smallest Src annotation containing the given position.
|
-- | Find the smallest Src annotation containing the given position.
|
||||||
|
@ -92,7 +98,12 @@ srcAt pos expr = do Note src _ <- exprAt pos expr
|
||||||
-- textual error message.
|
-- textual error message.
|
||||||
annotateLet :: Position -> WellTyped -> Either String (Src, Expr Src Void)
|
annotateLet :: Position -> WellTyped -> Either String (Src, Expr Src Void)
|
||||||
annotateLet pos expr = do
|
annotateLet pos expr = do
|
||||||
annotateLet' pos empty (fromWellTyped expr)
|
expr' <- case splitMultiLetSrc (fromWellTyped expr) of
|
||||||
|
Just e -> return e
|
||||||
|
Nothing -> Left "The impossible happened: failed to split let\
|
||||||
|
\ blocks when preprocessing for annotateLet'."
|
||||||
|
annotateLet' pos empty expr'
|
||||||
|
|
||||||
|
|
||||||
annotateLet' :: Position -> Context (Expr Src Void) -> Expr Src Void
|
annotateLet' :: Position -> Context (Expr Src Void) -> Expr Src Void
|
||||||
-> Either String (Src, Expr Src Void)
|
-> Either String (Src, Expr Src Void)
|
||||||
|
@ -133,6 +144,13 @@ annotateLet' pos ctx expr = do
|
||||||
(e:[]) -> annotateLet' pos ctx e
|
(e:[]) -> annotateLet' pos ctx e
|
||||||
_ -> Left "You weren't pointing at a let binder!"
|
_ -> Left "You weren't pointing at a let binder!"
|
||||||
|
|
||||||
|
-- Make sure all lets in a multilet are annotated with their source information
|
||||||
|
splitMultiLetSrc :: Expr Src a -> Maybe (Expr Src a)
|
||||||
|
splitMultiLetSrc (Note src (Let b (Let b' e))) = do
|
||||||
|
src' <- getLetInner src
|
||||||
|
splitMultiLetSrc (Note src (Let b (Note src' (Let b' e))))
|
||||||
|
splitMultiLetSrc expr = subExpressions splitMultiLetSrc expr
|
||||||
|
|
||||||
-- Check if range lies completely inside a given subexpression.
|
-- Check if range lies completely inside a given subexpression.
|
||||||
-- This version takes trailing whitespace into account
|
-- This version takes trailing whitespace into account
|
||||||
-- (c.f. `sanitiseRange` from Backend.Diangostics).
|
-- (c.f. `sanitiseRange` from Backend.Diangostics).
|
||||||
|
|
|
@ -37,7 +37,7 @@ hoveringSpec dir =
|
||||||
case (extractContents typeHover, extractContents funcHover) of
|
case (extractContents typeHover, extractContents funcHover) of
|
||||||
(HoverContents typeContent, HoverContents functionContent) -> do
|
(HoverContents typeContent, HoverContents functionContent) -> do
|
||||||
getValue typeContent `shouldBe` "Type"
|
getValue typeContent `shouldBe` "Type"
|
||||||
getValue functionContent `shouldBe` "{ home : Text, name : Text }"
|
getValue functionContent `shouldBe` "\8704(_isAdmin : Bool) \8594 { home : Text, name : Text }"
|
||||||
_ -> error "test failed"
|
_ -> error "test failed"
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user