Improve completion contexts (#495)

The completion context determines whether we show completions for
types or completions for values. This is done by looking at the parsed
module.

This PR fixes two things:

1. While we only use the parsed module for getting the context
   previously we got the parsed module out of the typechecked
   module. This means that if you have a module that parses but
   doesn’t typecheck, we will use the parsed module at the point where
   it last typechecked which is out of date and produces incorrect (or
   just no) contexts.
2. When we could not find a context, we defaulted to assuming we are
   in a value context. Especially in combination with 1 but also just
   in general, this is rather annoying. If we aren’t sure we should
   show the user everything we have and not filter out some
   completions. Filtering out completions interacts particularly badly
   with VSCode’s default behavior of accepting the first completion
   when you press return.

Author: cocreature

src/Development/IDE/Plugin/Completions.hs

@@ -2,6 +2,8 @@
 
 module Development.IDE.Plugin.Completions(plugin) where
 
+import Control.Applicative
+import Data.Maybe
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Core as LSP
@@ -10,8 +12,6 @@ import Language.Haskell.LSP.Types.Capabilities
 import Development.Shake.Classes
 import Development.Shake
 import GHC.Generics
-import Data.Maybe
-import HscTypes
 
 import Development.IDE.Plugin
 import Development.IDE.Core.Service
@@ -37,14 +37,14 @@ produceCompletions =
         packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
         case (tm, packageState) of
             (Just tm', Just packageState') -> do
-                cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
+                cdata <- liftIO $ cacheDataProducer packageState'
                                                     (tmrModule tm') parsedDeps
-                return ([], Just (cdata, tm'))
+                return ([], Just cdata)
             _ -> return ([], Nothing)
 
 
 -- | Produce completions info for a file
-type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
+type instance RuleResult ProduceCompletions = CachedCompletions
 
 data ProduceCompletions = ProduceCompletions
     deriving (Eq, Show, Typeable, Generic)
@@ -67,17 +67,21 @@ getCompletionsLSP lsp ide
     fmap Right $ case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath path
-        (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)
+        (ideOpts, compls) <- runAction ide $ do
+            opts <- getIdeOptions
+            compls <- useWithStale ProduceCompletions npath
+            pm <- useWithStale GetParsedModule npath
+            pure (opts, liftA2 (,) compls pm)
         case compls of
-          Just ((cci', tm'), mapping) -> do
-            let position' = fromCurrentPosition mapping position
+          Just ((cci', _), (pm, mapping)) -> do
+            let !position' = fromCurrentPosition mapping position
             pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
             case (pfix, completionContext) of
               (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
                 -> return (Completions $ List [])
               (Just pfix', _) -> do
                 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
-                Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
+                Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
               _ -> return (Completions $ List [])
           _ -> return (Completions $ List [])
       _ -> return (Completions $ List [])

src/Development/IDE/Plugin/Completions/Logic.hs

@@ -210,9 +210,10 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 
-cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
-cacheDataProducer packageState dflags tm deps = do
+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
+cacheDataProducer packageState tm deps = do
   let parsedMod = tm_parsed_module tm
+      dflags = hsc_dflags packageState
       curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
       Just (_,limports,_,_) = tm_renamed_source tm
 
@@ -306,16 +307,13 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
   where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
 
 -- | Returns the cached completions for the given module and position.
-getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
 getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
-               tm prefixInfo caps withSnippets = do
+               pm prefixInfo caps withSnippets = do
   let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
       enteredQual = if T.null prefixModule then "" else prefixModule <> "."
       fullPrefix  = enteredQual <> prefixText
 
-      -- default to value context if no explicit context
-      context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
-
       {- correct the position by moving 'foo :: Int -> String ->    '
                                                                     ^
           to                             'foo :: Int -> String ->    '
@@ -344,10 +342,11 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
         where
           isTypeCompl = isTcOcc . occName . origName
           -- completions specific to the current context
-          ctxCompls' = case context of
-                        TypeContext -> filter isTypeCompl compls
-                        ValueContext -> filter (not . isTypeCompl) compls
-                        _ -> filter (not . isTypeCompl) compls
+          ctxCompls' = case getCContext pos pm of
+                        Nothing -> compls
+                        Just TypeContext -> filter isTypeCompl compls
+                        Just ValueContext -> filter (not . isTypeCompl) compls
+                        Just _ -> filter (not . isTypeCompl) compls
           -- Add whether the text to insert has backticks
           ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
 

test/exe/Main.hs

@@ -1630,6 +1630,27 @@ completionTests
         docId <- openDoc' "A.hs" "haskell" source
         compls <- getCompletions docId (Position 1 9)
         liftIO $ compls @?= [keywordItem "newtype"]
+    , testSessionWait "type context" $ do
+        let source = T.unlines
+                [ "{-# OPTIONS_GHC -Wunused-binds #-}"
+                , "module A () where"
+                , "f = f"
+                ]
+        docId <- openDoc' "A.hs" "haskell" source
+        expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
+        changeDoc docId
+             [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
+                   [ "{-# OPTIONS_GHC -Wunused-binds #-}"
+                   , "module A () where"
+                   , "f = f"
+                   , "g :: Intege"
+                   ]
+             ]
+        -- At this point the module parses but does not typecheck.
+        -- This should be sufficient to detect that we are in a
+        -- type context and only show the completion to the type.
+        compls <- getCompletions docId (Position 3 11)
+        liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
     ]
   where
     dropDocs :: CompletionItem -> CompletionItem