From 619788f7950c821b51c9d2144cb0a81ab9c04ca5 Mon Sep 17 00:00:00 2001 From: Frederik Ramcke Date: Wed, 20 Nov 2019 17:02:06 +0000 Subject: [PATCH] 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. --- .../src/Dhall/LSP/Backend/Parsing.hs | 18 ++++++++--- .../src/Dhall/LSP/Backend/Typing.hs | 32 +++++++++++++++---- dhall-lsp-server/tests/Main.hs | 2 +- 3 files changed, 40 insertions(+), 12 deletions(-) diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs index 1b41134..fb09b7d 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs @@ -24,7 +24,6 @@ import Control.Applicative (optional, (<|>)) import qualified Text.Megaparsec as Megaparsec import Text.Megaparsec (SourcePos(..)) - -- | 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 -- 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 setSourcePos left _let + nonemptyWhitespace _ <- label + whitespace _ <- optional (do _ <- _colon - expr) + nonemptyWhitespace + _ <- expr + whitespace) _equal + whitespace _ <- expr + whitespace _ <- optional _in + whitespace begin <- getSourcePos tokens <- Megaparsec.takeRest end <- getSourcePos @@ -53,11 +59,15 @@ getLetAnnot (Src left _ text) = Megaparsec.parseMaybe (unParser parseLetAnnot) t where parseLetAnnot = do setSourcePos left _let + nonemptyWhitespace _ <- label + whitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match $ optional (do _ <- _colon - expr) + nonemptyWhitespace + _ <- expr + whitespace) end <- getSourcePos _ <- Megaparsec.takeRest return (Src begin end tokens) @@ -73,7 +83,7 @@ getLetIdentifier src@(Src left _ text) = where parseLetIdentifier = do setSourcePos left _let - whitespace + nonemptyWhitespace begin <- getSourcePos (tokens, _) <- Megaparsec.match label end <- getSourcePos diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs index aad3c68..2801209 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs @@ -10,7 +10,7 @@ import Control.Applicative ((<|>)) import Data.Bifunctor (first) import Data.Void (absurd, Void) -import Dhall.LSP.Backend.Parsing (getLetAnnot, getLetIdentifier, +import Dhall.LSP.Backend.Parsing (getLetInner, getLetAnnot, getLetIdentifier, getLamIdentifier, getForallIdentifier) import Dhall.LSP.Backend.Diagnostics (Position, Range(..), rangeFromDhall) import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped) @@ -20,7 +20,10 @@ import Dhall.LSP.Backend.Dhall (WellTyped, fromWellTyped) -- that subexpression if possible. typeAt :: Position -> WellTyped -> Either String (Maybe Src, Expr Src Void) 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' case mSrc of 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' = 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 _ <- typeWithA absurd ctx 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. exprAt :: Position -> Expr Src a -> Maybe (Expr Src a) -exprAt pos e@(Note _ expr) = exprAt pos expr <|> Just e -exprAt pos expr = +exprAt pos e = do e' <- splitMultiLetSrc e + 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 in case [ (src, e) | (Note src e) <- subExprs, pos `inside` src ] of [] -> 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. @@ -92,7 +98,12 @@ srcAt pos expr = do Note src _ <- exprAt pos expr -- textual error message. annotateLet :: Position -> WellTyped -> Either String (Src, Expr Src Void) 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 -> Either String (Src, Expr Src Void) @@ -133,6 +144,13 @@ annotateLet' pos ctx expr = do (e:[]) -> annotateLet' pos ctx e _ -> 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. -- This version takes trailing whitespace into account -- (c.f. `sanitiseRange` from Backend.Diangostics). diff --git a/dhall-lsp-server/tests/Main.hs b/dhall-lsp-server/tests/Main.hs index b9478dd..f20714f 100644 --- a/dhall-lsp-server/tests/Main.hs +++ b/dhall-lsp-server/tests/Main.hs @@ -37,7 +37,7 @@ hoveringSpec dir = case (extractContents typeHover, extractContents funcHover) of (HoverContents typeContent, HoverContents functionContent) -> do 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" pure ()