dhall-lsp-server: Implement completion support (#1190)

* Implement completion support

Completes the following:
- environment variables
- local imports
- identifiers in scope (as well as built-ins)
- record projections
- union constructors

* Add support for general dependent types

Removes the non-dependent let path. Needed since #1164 added support for
general dependent types.

* Remove unused import

* Use monad instance to cast between `Expr Src _`

As suggested by @Gabriel439: Use `typeOf (do _ <- expr; holeExpr)`
instead of `fmap undefined expr`. In the absence of `Embed` constructors
(in this case `Import`s) the two are equivalent.

* Simplify completeFromContext

Caught by @Gabriel439

* Remove debug code

* Add 1s timeout to listDirectory call

As pointed out by @Gabriel439, listDirectory can be a potentially
expensive operation. Adding a timeout should improve the user
experience.

* Fix unclean merge

dhall-lsp-server/dhall-lsp-server.cabal

@@ -20,6 +20,7 @@ source-repository head
 
 library
   exposed-modules:
+      Dhall.LSP.Backend.Completion
       Dhall.LSP.Backend.Dhall
       Dhall.LSP.Backend.Diagnostics
       Dhall.LSP.Backend.Freezing
@@ -44,6 +45,7 @@ library
     , bytestring           >= 0.10.8.2 && < 0.11
     , containers           >= 0.5.11.0 && < 0.7
     , data-default         >= 0.7.1.1  && < 0.8
+    , directory            >= 1.2.2.0  && < 1.4
     , dhall                >= 1.25.0   && < 1.26
     , dhall-json           >= 1.4      && < 1.5
     , filepath             >= 1.4.2    && < 1.5

dhall-lsp-server/src/Dhall/LSP/Backend/Completion.hs

@@ -0,0 +1,182 @@
+module Dhall.LSP.Backend.Completion where
+
+import Data.Text (Text)
+import Data.Void (absurd)
+import Dhall.LSP.Backend.Diagnostics (Position, positionToOffset)
+import System.Directory (doesDirectoryExist, listDirectory)
+import System.FilePath (takeDirectory, (</>))
+import System.Environment (getEnvironment)
+import System.Timeout (timeout)
+
+import Dhall.Context (empty, toList)
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Text as Text
+import Dhall.Context (Context, insert)
+import Dhall.Core (Expr(..), Binding(..), Var(..), normalize, shift, subst, pretty, reservedIdentifiers)
+import Dhall.TypeCheck (X, typeWithA, typeOf)
+import Dhall.Parser (Src, exprFromText)
+import qualified Dhall.Map
+import qualified Data.HashSet as HashSet
+
+import Dhall.LSP.Backend.Parsing (holeExpr)
+
+-- | Given the cursor position construct the corresponding 'completion query'
+-- consisting of the leadup, i.e. text leading up to the word prefix that is to
+-- be completed, as well as the prefix that is to be completed.
+completionQueryAt :: Text -> Position -> (Text, Text)
+completionQueryAt text pos = (completionLeadup, completionPrefix)
+ where
+  off = positionToOffset text pos
+  text' = Text.take off text
+  breakEnd :: (Char -> Bool) -> Text -> (Text, Text)
+  breakEnd p =
+    (\(l,r) -> (Text.reverse l, Text.reverse r)) . Text.break p . Text.reverse
+  (completionPrefix, completionLeadup) =
+    breakEnd (`elem` (" \t\n[(,=+*&|}#?>" :: [Char])) text'
+
+-- | A completion result, optionally annotated with type information.
+data Completion =
+  Completion {
+    completeText :: Text,
+    completeType :: Maybe (Expr Src X) }
+
+-- | Complete file names.
+completeLocalImport :: FilePath -> FilePath -> IO [Completion]
+completeLocalImport relativeTo prefix = do
+  let dir = takeDirectory relativeTo </> takeDirectory prefix
+  exists <- doesDirectoryExist dir
+  if not exists
+  then return []
+  else do
+    let second = 10 ^ (6 :: Int)
+    mFiles <- timeout second (listDirectory dir)  -- 1s timeout
+    case mFiles of
+      Just files -> return (map (\file -> Completion (Text.pack file) Nothing) files)
+      Nothing -> return []
+
+-- | Complete environment variables.
+completeEnvironmentImport :: IO [Completion]
+completeEnvironmentImport = do
+  environment <- getEnvironment
+  let environmentImports = map (Text.pack . fst) environment
+  return $ map (\env -> Completion env Nothing) environmentImports
+
+
+-- | A completion context, consisting of the (approximated) type-checking
+-- context. We need to substitute 'dependent lets' later so we keep their values
+-- around.
+data CompletionContext =
+  CompletionContext {
+    context :: Context (Expr Src X),
+    -- values to be substituted for 'dependent let' behaviour
+    values :: Context (Expr Src X) }
+
+-- | Given a 'binders expression' (with arbitrarily many 'holes') construct the
+-- corresponding completion context.
+buildCompletionContext :: Expr Src X -> CompletionContext
+buildCompletionContext = buildCompletionContext' empty empty
+
+buildCompletionContext' :: Context (Expr Src X) -> Context (Expr Src X)
+  -> Expr Src X -> CompletionContext
+buildCompletionContext' context values (Let (Binding x mA a :| []) e)
+  -- We prefer the actual value over the annotated type in order to get
+  -- 'dependent let' behaviour whenever possible.
+  | Right _A <- typeWithA absurd context a =
+    let _A' = normalize _A
+
+        a' = normalize a
+        e' = subst (V x 0) a' e
+
+        context' = fmap (shift 1 (V x 0)) $ insert x _A' context
+        values' = fmap (shift 1 (V x 0)) $ insert x a' values
+
+    in buildCompletionContext' context' values' e'
+
+  -- fall back to annotated type if body doesn't type check; bind to `holeExpr`
+  | Just _A <- mA
+  , Right _ <- typeWithA absurd context _A =
+    let _A' = normalize _A
+
+        context' = fmap (shift 1 (V x 0)) $ insert x _A' context
+        values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
+
+    in buildCompletionContext' context' values' e
+
+  -- if nothing works, only remember the name (but bind to `holeExpr`)
+  | otherwise =
+    let context' = fmap (shift 1 (V x 0)) $ insert x holeExpr context
+        values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
+
+    in buildCompletionContext' context' values' e
+
+buildCompletionContext' context values (Lam x _A b) =
+  let _A' | Right _ <- typeWithA absurd context _A = normalize _A
+          | otherwise = holeExpr
+
+      context' = fmap (shift 1 (V x 0)) $ insert x _A' context
+      values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
+
+    in buildCompletionContext' context' values' b
+
+buildCompletionContext' context values (Pi x _A b) =
+  let _A' | Right _ <- typeWithA absurd context _A = normalize _A
+          | otherwise = holeExpr
+
+      context' = fmap (shift 1 (V x 0)) $ insert x _A' context
+      values' = fmap (shift 1 (V x 0)) $ insert x holeExpr values
+
+    in buildCompletionContext' context' values' b
+
+-- catch-all
+buildCompletionContext' context values _ = CompletionContext context values
+
+-- Helper. Given `Dhall.Context.toList ctx` construct the corresponding variable
+-- names.
+contextToVariables :: [(Text, Expr Src X)] -> [Var]
+contextToVariables  [] = []
+contextToVariables ((name, _) : rest) =
+  V name 0 : map (inc name) (contextToVariables rest)
+ where inc x (V y i) | x == y = V x (i + 1)
+                     | otherwise = V y i
+
+-- | Complete identifiers from the given completion context.
+completeFromContext :: CompletionContext -> [Completion]
+completeFromContext (CompletionContext context _) =
+  let context' = toList context
+      completeReserved keyword
+        | Right expr <- exprFromText "" keyword
+        , Right typ <- typeOf (do _ <- expr; holeExpr) =
+          Completion keyword (Just typ)
+        | otherwise = Completion keyword Nothing
+      reserved = map completeReserved $ HashSet.toList reservedIdentifiers
+  in [ Completion (pretty var) (if typ == holeExpr then Nothing else Just typ)
+     | (var, (_, typ)) <- zip (contextToVariables context') context' ]
+     ++ reserved
+
+-- | Complete union constructors and record projections.
+completeProjections :: CompletionContext -> Expr Src X -> [Completion]
+completeProjections (CompletionContext context values) expr =
+  -- substitute 'dependent lets', necessary for completion of unions
+  let values' = toList values
+      subs = filter ((/= holeExpr) . snd) $ zip (contextToVariables values') (map snd values')
+      expr' = foldl (\e (x,val) -> subst x val e) expr subs
+
+  in case typeWithA absurd context expr' of
+      Left _ -> []
+      Right _A ->
+        let expr'' = normalize expr'
+        in completeUnion expr'' expr'' ++ completeRecord (normalize _A)
+
+ where
+  -- complete a union constructor by inspecting the union value
+  completeUnion _A (Union m) =
+    let constructor (k, Nothing) = Completion k (Just _A)
+        constructor (k, Just v) = Completion k (Just (Pi k v _A))
+     in map constructor (Dhall.Map.toList m)
+  completeUnion _ _ = []
+
+
+  -- complete a record projection by inspecting the record type
+  completeRecord (Record m) =
+    map (\(name, typ) -> Completion name (Just typ)) (Dhall.Map.toList m)
+  completeRecord _ = []

dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs

@@ -4,13 +4,21 @@ module Dhall.LSP.Backend.Parsing
   , getLetAnnot
   , getLetIdentifier
   , getLamIdentifier
-  , getForallIdentifier)
+  , getForallIdentifier
+  , binderExprFromText
+  , holeExpr
+  )
 where
 
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import Dhall.Core (Expr(..), Import, Binding(..), Var(..))
 import Dhall.Src (Src(..))
 import Dhall.Parser
 import Dhall.Parser.Token
 import Dhall.Parser.Expression
+import Text.Megaparsec ((<|>), try, skipManyTill, lookAhead, anySingle,
+  notFollowedBy, eof, takeRest)
 
 import Control.Applicative (optional)
 import qualified Text.Megaparsec as Megaparsec
@@ -122,3 +130,112 @@ setSourcePos :: SourcePos -> Parser ()
 setSourcePos src = Megaparsec.updateParserState
                      (\(Megaparsec.State s o (Megaparsec.PosState i o' _ t l)) ->
                        Megaparsec.State s o (Megaparsec.PosState i o' src t l))
+
+
+-- | An expression that is guaranteed not to typecheck. Can be used a
+-- placeholder type to emulate 'lazy' contexts, when typechecking something in a
+-- only partly well-typed context.
+holeExpr :: Expr s a
+-- The illegal variable name ensures that it can't be bound by the user!
+holeExpr = Var (V "" 0)
+
+-- | Approximate the type-checking context at the end of the input. Tries to
+-- parse as many binders as possible. Very messy!
+binderExprFromText :: Text -> Expr Src Import
+binderExprFromText txt =
+  case Megaparsec.parseMaybe (unParser parseBinderExpr) (txt <> " ") of
+    Just e -> e
+    Nothing -> holeExpr
+  where
+    -- marks the beginning of the next binder
+    boundary = _let <|> _forall <|> _lambda
+
+    -- A binder that is out of scope at the end of the input. Discarded in the
+    -- resulting 'binder expression'.
+    closedBinder = closedLet <|> closedLambda <|> closedPi
+
+    closedLet = do
+      _let
+      _ <- label
+      _ <- optional (do
+        _colon
+        expr)
+      _equal
+      _ <- expr
+      (do
+        _in
+        _ <- expr
+        return ())
+        <|> closedLet
+
+    closedLambda = do
+      _lambda
+      _openParens
+      _ <- label
+      _colon
+      _ <- expr
+      _closeParens
+      _arrow
+      _ <- expr
+      return ()
+
+    closedPi = do
+      _forall
+      _openParens
+      _ <- label
+      _colon
+      _ <- expr
+      _closeParens
+      _arrow
+      _ <- expr
+      return ()
+
+    -- Try to parse as many binders as possible. Skip malformed input and
+    -- 'closed' binders that are already out of scope at the end of the input.
+    parseBinderExpr = do
+      try (do
+          skipManyTill anySingle (lookAhead boundary)
+          try (do
+              closedBinder
+              notFollowedBy eof
+              parseBinderExpr)
+            <|> try (letBinder <|> lambdaBinder <|> forallBinder)
+            <|> (do
+              boundary
+              parseBinderExpr))
+        <|> (do
+          _ <- takeRest
+          return holeExpr)
+
+    letBinder = do
+      _let
+      name <- label
+      mType <- optional (do _colon; expr)
+
+      -- if the bound value does not parse, skip and replace with 'hole'
+      value <- try (do _equal; expr)
+          <|> (do skipManyTill anySingle (lookAhead boundary <|> _in); return holeExpr)
+      inner <- parseBinderExpr
+      return (Let (Binding name mType value :| []) inner)
+
+    forallBinder = do
+      _forall
+      _openParens
+      name <- label
+      _colon
+      -- if the bound type does not parse, skip and replace with 'hole'
+      typ <- try (do e <- expr; _closeParens; _arrow; return e)
+          <|> (do skipManyTill anySingle _arrow; return holeExpr)
+      inner <- parseBinderExpr
+      return (Pi name typ inner)
+
+    lambdaBinder = do
+      _lambda
+      _openParens
+      name <- label
+      _colon
+      -- if the bound type does not parse, skip and replace with 'hole'
+      typ <- try (do e <- expr; _closeParens; _arrow; return e)
+          <|> (do skipManyTill anySingle _arrow; return holeExpr)
+      inner <- parseBinderExpr
+      return (Lam name typ inner)

dhall-lsp-server/src/Dhall/LSP/Backend/Typing.hs

@@ -2,7 +2,7 @@ module Dhall.LSP.Backend.Typing (annotateLet, exprAt, srcAt, typeAt) where
 
 import Dhall.Context (Context, insert, empty)
 import Dhall.Core (Expr(..), Binding(..), Const(..), subExpressions, normalize, shift, subst, Var(..))
-import Dhall.TypeCheck (typeWithA, X(..), TypeError(..))
+import Dhall.TypeCheck (typeWithA, X, TypeError(..))
 import Dhall.Parser (Src(..))
 
 import Data.List.NonEmpty (NonEmpty (..))

dhall-lsp-server/src/Dhall/LSP/Handlers.hs

@@ -13,6 +13,8 @@ import Dhall.Import (localToPath)
 import Dhall.Parser (Src(..))
 import Dhall.TypeCheck (X)
 
+import Dhall.LSP.Backend.Completion (Completion(..), completionQueryAt,
+  completeEnvironmentImport, completeLocalImport, buildCompletionContext, completeProjections, completeFromContext)
 import Dhall.LSP.Backend.Dhall (FileIdentifier, parse, load, typecheck,
   fileIdentifierFromFilePath, fileIdentifierFromURI, invalidate, parseWithHeader)
 import Dhall.LSP.Backend.Diagnostics (Range(..), Diagnosis(..), explain,
@@ -21,6 +23,7 @@ import Dhall.LSP.Backend.Formatting (formatExprWithHeader)
 import Dhall.LSP.Backend.Freezing (computeSemanticHash, getImportHashPosition,
   stripHash, getAllImportsWithHashPositions)
 import Dhall.LSP.Backend.Linting (Suggestion(..), suggest, lint)
+import Dhall.LSP.Backend.Parsing (binderExprFromText)
 import Dhall.LSP.Backend.Typing (typeAt, annotateLet, exprAt)
 import Dhall.LSP.State
 
@@ -34,14 +37,13 @@ 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 Data.Text (Text, isPrefixOf)
 import qualified Data.Text as Text
 import qualified Network.URI as URI
 import qualified Network.URI.Encode as URI
 import Text.Megaparsec (SourcePos(..), unPos)
 import System.FilePath
 
-
 -- 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.
@@ -430,6 +432,93 @@ executeFreezeImport request = do
   lspRequest LSP.ReqApplyWorkspaceEdit J.WorkspaceApplyEdit
     (J.ApplyWorkspaceEditParams edit)
 
+completionHandler :: J.CompletionRequest -> HandlerM ()
+completionHandler request = do
+  let uri = request ^. J.params . J.textDocument . J.uri
+      line = request ^. J.params . J.position . J.line
+      col = request ^. J.params . J.position . J.character
+
+  txt <- readUri uri
+  let (completionLeadup, completionPrefix) = completionQueryAt txt (line, col)
+
+  let computeCompletions
+        -- environment variable
+        | "env:" `isPrefixOf` completionPrefix =
+          liftIO $ completeEnvironmentImport
+
+        -- local import
+        | any (`isPrefixOf` completionPrefix) [ "/", "./", "../", "~/" ] = do
+          let relativeTo | Just path <- J.uriToFilePath uri = path
+                         | otherwise = "."
+          liftIO $ completeLocalImport relativeTo (Text.unpack completionPrefix)
+
+        -- record projection / union constructor
+        | (target, _) <- Text.breakOnEnd "." completionPrefix
+        , not (Text.null target) = do
+          let bindersExpr = binderExprFromText completionLeadup
+
+          fileIdentifier <- fileIdentifierFromUri uri
+          cache <- use importCache
+          loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache
+
+          (cache', bindersExpr') <-
+            case loadedBinders of
+              Right (cache', binders) -> do
+                return (cache', binders)
+              Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")
+
+          let completionContext = buildCompletionContext bindersExpr'
+
+          targetExpr <- case parse (Text.dropEnd 1 target) of
+            Right e -> return e
+            Left _ -> throwE (Log, "Could not complete projection; prefix did not parse.")
+
+          loaded' <- liftIO $ load fileIdentifier targetExpr cache'
+          case loaded' of
+            Right (cache'', targetExpr') -> do
+              assign importCache cache''
+              return (completeProjections completionContext targetExpr')
+            Left _ -> return []
+
+        -- complete identifiers in scope
+        | otherwise = do
+          let bindersExpr = binderExprFromText completionLeadup
+
+          fileIdentifier <- fileIdentifierFromUri uri
+          cache <- use importCache  -- todo save cache afterwards
+          loadedBinders <- liftIO $ load fileIdentifier bindersExpr cache
+
+          bindersExpr' <-
+            case loadedBinders of
+              Right (cache', binders) -> do
+                assign importCache cache'
+                return binders
+              Left _ -> throwE (Log, "Could not complete projection; failed to load binders expression.")
+
+          let context = buildCompletionContext bindersExpr'
+          return (completeFromContext context)
+
+  completions <- computeCompletions
+
+  let item (Completion {..}) = J.CompletionItem {..}
+       where
+        _label = completeText
+        _kind = Nothing
+        _detail = fmap pretty completeType
+        _documentation = Nothing
+        _deprecated = Nothing
+        _preselect = Nothing
+        _sortText = Nothing
+        _filterText = Nothing
+        _insertText = Nothing
+        _insertTextFormat = Nothing
+        _textEdit = Nothing
+        _additionalTextEdits = Nothing
+        _commitCharacters = Nothing
+        _command = Nothing
+        _xdata = Nothing
+  lspRespond LSP.RspCompletion request $ J.Completions (J.List (map item completions))
+
 
 -- handler that doesn't do anything. Useful for example to make haskell-lsp shut
 -- up about unhandled DidChangeTextDocument notifications (which are already

dhall-lsp-server/src/Dhall/LSP/Server.hs

@@ -14,7 +14,8 @@ import qualified System.Log.Logger
 import Dhall.LSP.State
 import Dhall.LSP.Handlers (nullHandler, wrapHandler, hoverHandler,
   didOpenTextDocumentNotificationHandler, didSaveTextDocumentNotificationHandler,
-  executeCommandHandler, documentFormattingHandler, documentLinkHandler)
+  executeCommandHandler, documentFormattingHandler, documentLinkHandler,
+  completionHandler)
 
 -- | The main entry point for the LSP server.
 run :: Maybe FilePath -> IO ()
@@ -65,6 +66,10 @@ syncOptions = J.TextDocumentSyncOptions
 -- Server capabilities. Tells the LSP client that we can execute commands etc.
 lspOptions :: LSP.Core.Options
 lspOptions = def { LSP.Core.textDocumentSync = Just syncOptions
+                 , LSP.Core.completionProvider =
+                     Just (J.CompletionOptions {
+                         _resolveProvider = Nothing
+                       , _triggerCharacters = Just [":", ".", "/"] })
                  , LSP.Core.executeCommandProvider =
                      -- Note that this registers the dhall.server.lint command
                      -- with VSCode, which means that our plugin can't expose a
@@ -93,4 +98,5 @@ lspHandlers state
         , LSP.Core.executeCommandHandler                    = Just $ wrapHandler state executeCommandHandler
         , LSP.Core.documentFormattingHandler                = Just $ wrapHandler state documentFormattingHandler
         , LSP.Core.documentLinkHandler                      = Just $ wrapHandler state documentLinkHandler
+        , LSP.Core.completionHandler                        = Just $ wrapHandler state completionHandler
         }