Completions need not depend on typecheck of the current file (#670)

* Faster completions

* optimize withProgressVar

We never remove elements from the map so alter is unnecesary

* [ghcide-bench] accept ghcide options

* Expand completion tests suite

* hlints

* completions for local foreign decls

* Minor improvements for local completions

* Restore completion docs in legacy code path

* Compatibility with GHC < 8.8

* fix merge issue

* address review feedback

.hlint.yaml

@@ -95,7 +95,7 @@
 - flags:
   - default: false
   - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]}
-  - {name: [-Wno-dodgy-imports], within: Main}
+  - {name: [-Wno-dodgy-imports], within: [Main, Development.IDE.GHC.Compat]}
 # - modules:
 #   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
 #   - {name: Control.Arrow, within: []} # Certain modules are banned entirely

bench/hist/Main.hs

@@ -204,7 +204,7 @@ main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
                 "--samples=" <> show samples,
                 "--csv=" <> outcsv,
                 "--example-package-version=3.0.0.0",
-                "--rts=-I0.5",
+                "--ghcide-options= +RTS -I0.5 -RTS",
                 "--ghcide=" <> ghcide,
                 "--select",
                 unescaped (unescapeExperiment (Escaped $ dropExtension exp))

bench/lib/Experiments.hs

@@ -146,7 +146,7 @@ data Config = Config
     shakeProfiling :: !(Maybe FilePath),
     outputCSV :: !FilePath,
     buildTool :: !CabalStack,
-    rtsOptions :: ![String],
+    ghcideOptions :: ![String],
     matches :: ![String],
     repetitions :: Maybe Natural,
     ghcide :: FilePath,
@@ -177,7 +177,7 @@ configP =
     <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
     <*> strOption (long "csv" <> metavar "PATH" <> value "results.csv" <> showDefault)
     <*> flag Cabal Stack (long "stack" <> help "Use stack (by default cabal is used)")
-    <*> many (strOption (long "rts" <> help "additional RTS options for ghcide"))
+    <*> many (strOption (long "ghcide-options" <> help "additional options for ghcide"))
     <*> many (strOption (short 's' <> long "select" <> help "select which benchmarks to run"))
     <*> optional (option auto (long "samples" <> metavar "NAT" <> help "override sampling count"))
     <*> strOption (long "ghcide" <> metavar "PATH" <> help "path to ghcide" <> value "ghcide")
@@ -283,11 +283,10 @@ runBenchmarks allBenchmarks = do
           "--cwd",
           dir,
           "+RTS",
-          "-S" <> gcStats name
+          "-S" <> gcStats name,
+          "-RTS"
         ]
-          ++ rtsOptions ?config
-          ++ [ "-RTS"
-             ]
+          ++ ghcideOptions ?config
           ++ concat
             [ ["--shake-profiling", path]
               | Just path <- [shakeProfiling ?config]

src/Development/IDE/Core/Compile.hs

@@ -12,6 +12,7 @@ module Development.IDE.Core.Compile
   , RunSimplifier(..)
   , compileModule
   , parseModule
+  , parseHeader
   , typecheckModule
   , computePackageDeps
   , addRelativeImport
@@ -483,6 +484,39 @@ getModSummaryFromImports fp contents = do
                 }
     return summary
 
+-- | Parse only the module header
+parseHeader
+       :: GhcMonad m
+       => DynFlags -- ^ flags to use
+       -> FilePath  -- ^ the filename (for source locations)
+       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
+       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
+parseHeader dflags filename contents = do
+   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
+   case unP Parser.parseHeader (mkPState dflags contents loc) of
+#if MIN_GHC_API_VERSION(8,10,0)
+     PFailed pst ->
+        throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
+#else
+     PFailed _ locErr msgErr ->
+        throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
+#endif
+     POk pst rdr_module -> do
+        let (warns, errs) = getMessages pst dflags
+        -- Just because we got a `POk`, it doesn't mean there
+        -- weren't errors! To clarify, the GHC parser
+        -- distinguishes between fatal and non-fatal
+        -- errors. Non-fatal errors are the sort that don't
+        -- prevent parsing from continuing (that is, a parse
+        -- tree can still be produced despite the error so that
+        -- further errors/warnings can be collected). Fatal
+        -- errors are those from which a parse tree just can't
+        -- be produced.
+        unless (null errs) $
+            throwE $ diagFromErrMsgs "parser" dflags errs
+
+        let warnings = diagFromErrMsgs "parser" dflags warns
+        return (warnings, rdr_module)
 
 -- | Given a buffer, flags, and file path, produce a
 -- parsed module (or errors) and any parse warnings. Does not run any preprocessors
@@ -521,7 +555,7 @@ parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
                -- errors are those from which a parse tree just can't
                -- be produced.
                unless (null errs) $
-                 throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags
+                 throwE $ diagFromErrMsgs "parser" dflags errs
 
                -- Ok, we got here. It's safe to continue.
                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

src/Development/IDE/Core/Rules.hs

@@ -683,9 +683,7 @@ getModSummaryRule = defineEarlyCutoff $ \GetModSummary f -> do
         getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
     case modS of
         Right ms -> do
-            -- Clear the contents as no longer needed
-            let !ms' = ms{ms_hspp_buf=Nothing}
-            return ( Just (computeFingerprint f dflags ms), ([], Just ms'))
+            return ( Just (computeFingerprint f dflags ms), ([], Just ms))
         Left diags -> return (Nothing, (diags, Nothing))
     where
         -- Compute a fingerprint from the contents of `ModSummary`,

src/Development/IDE/Core/Shake.hs

@@ -858,7 +858,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
         -- This functions are deliberately eta-expanded to avoid space leaks.
         -- Do not remove the eta-expansion without profiling a session with at
         -- least 1000 modifications.
-        where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
+        where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x
 
 
 

src/Development/IDE/GHC/Compat.hs

@@ -2,7 +2,10 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# OPTIONS -Wno-dodgy-imports #-}
 #include "ghc-api-version.h"
 
 -- | Attempt at hiding the GHC version differences we can.
@@ -37,11 +40,15 @@ module Development.IDE.GHC.Compat(
     pattern ClassOpSig,
     pattern IEThingAll,
     pattern IEThingWith,
+    pattern VarPat,
     GHC.ModLocation,
     Module.addBootSuffix,
     pattern ModLocation,
     getConArgs,
 
+    HasSrcSpan,
+    getLoc,
+
     module GHC
     ) where
 
@@ -54,7 +61,20 @@ import Packages
 
 import qualified GHC
 import GHC hiding (
-      ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, SigD, TypeSig, ModLocation
+      ClassOpSig,
+      DerivD,
+      ForD,
+      IEThingAll,
+      IEThingWith,
+      InstD,
+      TyClD,
+      ValD,
+      SigD,
+      TypeSig,
+      VarPat,
+      ModLocation,
+      HasSrcSpan,
+      getLoc
 #if MIN_GHC_API_VERSION(8,6,0)
     , getConArgs
 #endif
@@ -92,7 +112,7 @@ import System.IO.Error
 import Binary
 import Control.Exception (catch)
 import Data.ByteString (ByteString)
-import GhcPlugins hiding (ModLocation)
+import GhcPlugins (Hsc, srcErrorMessages)
 import NameCache
 import TcRnTypes
 import System.IO
@@ -210,6 +230,15 @@ pattern IEThingAll a <-
     GHC.IEThingAll a
 #endif
 
+pattern VarPat :: Located (IdP p) -> Pat p
+pattern VarPat x <-
+#if MIN_GHC_API_VERSION(8,6,0)
+    GHC.VarPat _ x
+#else
+    GHC.VarPat x
+#endif
+
+
 setHieDir :: FilePath -> DynFlags -> DynFlags
 setHieDir _f d =
 #if MIN_GHC_API_VERSION(8,8,0)
@@ -304,7 +333,20 @@ getHeaderImports
        )
 #if MIN_GHC_API_VERSION(8,8,0)
 getHeaderImports = Hdr.getImports
+
+type HasSrcSpan = GHC.HasSrcSpan
+getLoc :: HasSrcSpan a => a -> SrcSpan
+getLoc = GHC.getLoc
+
 #else
+
+class HasSrcSpan a where
+    getLoc :: a -> SrcSpan
+instance HasSrcSpan Name where
+    getLoc = nameSrcSpan
+instance HasSrcSpan (GenLocated SrcSpan a) where
+    getLoc = GHC.getLoc
+
 getHeaderImports a b c d =
     catch (Right <$> Hdr.getImports a b c d)
           (return . Left . srcErrorMessages)

src/Development/IDE/GHC/Util.hs

@@ -17,6 +17,7 @@ module Development.IDE.GHC.Util(
     ParseResult(..), runParser,
     lookupPackageConfig,
     textToStringBuffer,
+    bytestringToStringBuffer,
     stringBufferToByteString,
     moduleImportPath,
     cgGutsToCoreModule,
@@ -113,6 +114,9 @@ runParser flags str parser = unP parser parseState
 stringBufferToByteString :: StringBuffer -> ByteString
 stringBufferToByteString StringBuffer{..} = PS buf cur len
 
+bytestringToStringBuffer :: ByteString -> StringBuffer
+bytestringToStringBuffer (PS buf cur len) = StringBuffer{..}
+
 -- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
 prettyPrint :: Outputable a => a -> String
 prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

src/Development/IDE/Plugin/CodeAction.hs

@@ -46,7 +46,7 @@ import Data.List.Extra
 import qualified Data.Text as T
 import Data.Tuple.Extra ((&&&))
 import HscTypes
-import SrcLoc
+import SrcLoc (sortLocated)
 import Parser
 import Text.Regex.TDFA ((=~), (=~~))
 import Text.Regex.TDFA.Text()

src/Development/IDE/Plugin/Completions.hs

@@ -18,23 +18,48 @@ import Development.IDE.Plugin
 import Development.IDE.Core.Service
 import Development.IDE.Plugin.Completions.Logic
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options
+import Development.IDE.Core.Compile
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
+import Development.IDE.GHC.Compat (hsmodExports, ParsedModule(..), ModSummary (ms_hspp_buf))
+
 import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
+import Control.Monad.Trans.Except (runExceptT)
+import HscTypes (HscEnv(hsc_dflags))
+import Data.Maybe
+import Data.Functor ((<&>))
 
 #if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
-import Data.Maybe
 import Development.IDE.Import.DependencyInformation
 #endif
 
 plugin :: Plugin c
 plugin = Plugin produceCompletions setHandlersCompletion
 
+
 produceCompletions :: Rules ()
-produceCompletions =
+produceCompletions = do
     define $ \ProduceCompletions file -> do
+        local <- useWithStale LocalCompletions file
+        nonLocal <- useWithStale NonLocalCompletions file
+        let extract = fmap fst
+        return ([], extract local <> extract nonLocal)
+    define $ \LocalCompletions file -> do
+        pm <- useWithStale GetParsedModule file
+        case pm of
+            Just (pm, _) -> do
+                let cdata = localCompletionsForParsedModule pm
+                return ([], Just cdata)
+            _ -> return ([], Nothing)
+    define $ \NonLocalCompletions file -> do
+        -- For non local completions we avoid depending on the parsed module,
+        -- synthetizing a fake module with an empty body from the buffer
+        -- in the ModSummary, which preserves all the imports
+        ms <- fmap fst <$> useWithStale GetModSummary file
+        sess <- fmap fst <$> useWithStale GhcSessionDeps file
 
 -- When possible, rely on the haddocks embedded in our interface files
 -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
@@ -44,25 +69,61 @@ produceCompletions =
         deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
 #endif
-        tm <- fmap fst <$> useWithStale TypeCheck file
-        packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
-        case (tm, packageState) of
-            (Just tm', Just packageState') -> do
-                cdata <- liftIO $ cacheDataProducer packageState'
-                                                    (tmrModule tm') parsedDeps
-                return ([], Just cdata)
-            _ -> return ([], Nothing)
 
+        case (ms, sess) of
+            (Just ms, Just sess) -> do
+                -- After parsing the module remove all package imports referring to
+                -- these packages as we have already dealt with what they map to.
+                let env = hscEnv sess
+                    buf = fromJust $ ms_hspp_buf ms
+                    f = fromNormalizedFilePath file
+                    dflags = hsc_dflags env
+                pm <- liftIO $ evalGhcEnv env $ runExceptT $ parseHeader dflags f buf
+                case pm of
+                    Right (_diags, hsMod) -> do
+                        let hsModNoExports = hsMod <&> \x -> x{hsmodExports = Nothing}
+                            pm = ParsedModule
+                                    { pm_mod_summary = ms
+                                    , pm_parsed_source = hsModNoExports
+                                    , pm_extra_src_files = [] -- src imports not allowed
+                                    , pm_annotations = mempty
+                                    }
+                        tm <- liftIO $ typecheckModule (IdeDefer True) env pm
+                        case tm of
+                            (_, Just (_,TcModuleResult{..})) -> do
+                                cdata <- liftIO $ cacheDataProducer env tmrModule parsedDeps
+                                -- Do not return diags from parsing as they would duplicate
+                                -- the diagnostics from typechecking
+                                return ([], Just cdata)
+                            (_diag, _) ->
+                                return ([], Nothing)
+                    Left _diag ->
+                        return ([], Nothing)
+            _ -> return ([], Nothing)
 
 -- | Produce completions info for a file
 type instance RuleResult ProduceCompletions = CachedCompletions
+type instance RuleResult LocalCompletions = CachedCompletions
+type instance RuleResult NonLocalCompletions = CachedCompletions
 
 data ProduceCompletions = ProduceCompletions
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable ProduceCompletions
 instance NFData   ProduceCompletions
 instance Binary   ProduceCompletions
 
+data LocalCompletions = LocalCompletions
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable LocalCompletions
+instance NFData   LocalCompletions
+instance Binary   LocalCompletions
+
+data NonLocalCompletions = NonLocalCompletions
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable NonLocalCompletions
+instance NFData   NonLocalCompletions
+instance Binary   NonLocalCompletions
+
 
 -- | Generate code actions.
 getCompletionsLSP
@@ -91,6 +152,7 @@ getCompletionsLSP lsp ide
               (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
                 -> return (Completions $ List [])
               (Just pfix', _) -> do
+                  -- TODO pass the real capabilities here (or remove the logic for snippets)
                 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
                 Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
               _ -> return (Completions $ List [])