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.

Author: EggBaconAndSpam

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

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).

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 ()