diff --git a/cabal.project b/cabal.project index 8134d67bf9..8c014dd2e4 100644 --- a/cabal.project +++ b/cabal.project @@ -30,7 +30,7 @@ package ghcide write-ghc-environment-files: never -index-state: 2021-01-17T17:47:48Z +index-state: 2021-01-28T17:47:48Z allow-newer: active:base, diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 2c72f20266..104a060195 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -43,12 +43,13 @@ main = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion - LspMode lspArgs -> - launchHaskellLanguageServer lspArgs + _ -> launchHaskellLanguageServer args -launchHaskellLanguageServer :: LspArguments -> IO () -launchHaskellLanguageServer LspArguments{..} = do - whenJust argsCwd setCurrentDirectory +launchHaskellLanguageServer :: Arguments -> IO () +launchHaskellLanguageServer parsedArgs = do + case parsedArgs of + LspMode LspArguments{..} -> whenJust argsCwd setCurrentDirectory + _ -> pure () d <- getCurrentDirectory @@ -56,7 +57,10 @@ launchHaskellLanguageServer LspArguments{..} = do cradle <- findLocalCradle (d "a") setCurrentDirectory $ cradleRootDir cradle - when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess + case parsedArgs of + LspMode LspArguments{..} -> + when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess + _ -> pure () progName <- getProgName hPutStrLn stderr $ "Run entered for haskell-language-server-wrapper(" ++ progName ++ ") " diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 33f89a6bcf..244d381490 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -88,6 +88,7 @@ - Development.IDE.Spans.Calculate - Development.IDE.Spans.Documentation - Development.IDE.Spans.Common + - Development.IDE.Spans.AtPoint - Development.IDE.Plugin.CodeAction - Development.IDE.Plugin.Completions - Development.IDE.Plugin.Completions.Logic diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 1b4ee3649b..44b639c9a9 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -324,9 +324,15 @@ data BenchRun = BenchRun badRun :: BenchRun badRun = BenchRun 0 0 0 0 0 False +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return waitForProgressDone :: Session () -waitForProgressDone = - void(skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) +waitForProgressDone = loop + where + loop = do + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + done <- null <$> getIncompleteProgressSessions + unless done loop runBench :: (?config :: Config) => diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 11b4320d82..ab3cd26a92 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -1,15 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -module Arguments(Arguments(..), getArguments) where +module Arguments(Arguments, Arguments'(..), getArguments, IdeCmd(..)) where import Options.Applicative +import HieDb.Run +type Arguments = Arguments' IdeCmd -data Arguments = Arguments +data IdeCmd = Typecheck [FilePath] | DbCmd Options Command | LSP + +data Arguments' a = Arguments {argLSP :: Bool ,argsCwd :: Maybe FilePath - ,argFiles :: [FilePath] ,argsVersion :: Bool ,argsShakeProfiling :: Maybe FilePath ,argsOTMemoryProfiling :: Bool @@ -17,6 +20,7 @@ data Arguments = Arguments ,argsDisableKick :: Bool ,argsThreads :: Int ,argsVerbose :: Bool + ,argFilesOrCmd :: a } getArguments :: IO Arguments @@ -24,14 +28,12 @@ getArguments = execParser opts where opts = info (arguments <**> helper) ( fullDesc - <> progDesc "Used as a test bed to check your IDE will work" <> header "ghcide - the core of a Haskell IDE") arguments :: Parser Arguments arguments = Arguments - <$> switch (long "lsp" <> help "Start talking to an LSP server") + <$> switch (long "lsp" <> help "Start talking to an LSP client") <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory") - <*> many (argument str (metavar "FILES/DIRS...")) <*> switch (long "version" <> help "Show ghcide and GHC versions") <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory") <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect") @@ -39,3 +41,12 @@ arguments = Arguments <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation") <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) <*> switch (long "verbose" <> help "Include internal events in logging output") + <*> ( hsubparser (command "typecheck" (info (Typecheck <$> fileCmd) fileInfo) + <> command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo) + <> command "lsp" (info (pure LSP <**> helper) lspInfo) ) + <|> Typecheck <$> fileCmd ) + where + fileCmd = many (argument str (metavar "FILES/DIRS...")) + lspInfo = fullDesc <> progDesc "Start talking to an LSP client" + fileInfo = fullDesc <> progDesc "Used as a test bed to check your IDE will work" + hieInfo = fullDesc <> progDesc "Query .hie files" diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 582ce2597d..7cf421a98f 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -8,6 +8,7 @@ module Main(main) where import Arguments import Control.Concurrent.Extra import Control.Monad.Extra +import Control.Exception.Safe import Control.Lens ( (^.) ) import Data.Default import Data.List.Extra @@ -29,7 +30,7 @@ import Development.IDE.Types.Options import Development.IDE.Types.Logger import Development.IDE.Plugin import Development.IDE.Plugin.Test as Test -import Development.IDE.Session (loadSession) +import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb) import Development.Shake (ShakeOptions (shakeThreads)) import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages @@ -58,6 +59,8 @@ import Development.IDE.Plugin.HLS.GhcIde as GhcIde import Ide.Plugin.Config import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins) +import HieDb.Run (Options(..), runCommand) + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -78,13 +81,30 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + whenJust argsCwd IO.setCurrentDirectory + + + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + + case argFilesOrCmd of + DbCmd opts cmd -> do + mlibdir <- setInitialDynFlags + case mlibdir of + Nothing -> exitWith $ ExitFailure 1 + Just libdir -> + runCommand libdir opts{database = dbLoc} cmd + Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..} + _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..} + + +runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO () +runIde Arguments{..} hiedb hiechan = do -- lock to avoid overlapping output on stdout lock <- newLock let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - whenJust argsCwd IO.setCurrentDirectory - dir <- IO.getCurrentDirectory let hlsPlugins = pluginDescToIdePlugins $ @@ -107,14 +127,22 @@ main = do options = def { LSP.executeCommandCommands = Just hlsCommands , LSP.completionTriggerCharacters = Just "." } - - if argLSP then do + case argFilesOrCmd of + Nothing -> do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + + -- We want to set the global DynFlags right now, so that we can use + -- `unsafeGlobalDynFlags` even before the project is configured + -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath') + -- before calling this function + _mlibdir <- setInitialDynFlags + `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) + sessionLoader <- loadSession $ fromMaybe dir rootPath config <- fromMaybe def <$> getConfig let options = defOptions @@ -138,8 +166,8 @@ main = do unless argsDisableKick $ action kick initialise caps rules - getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs - else do + getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan + Just argFiles -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -174,7 +202,7 @@ main = do } defOptions = defaultIdeOptions sessionLoader logLevel = if argsVerbose then minBound else Info - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files @@ -203,7 +231,7 @@ main = do unless (null failed) (exitWith $ ExitFailure (length failed)) -{-# ANN main ("HLint: ignore Use nubOrd" :: String) #-} +{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-} expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 11647ab724..6fc3489353 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -47,7 +47,7 @@ library deepseq, directory, dlist, - extra, + extra >= 1.7.4, fuzzy, filepath, fingertree, @@ -60,6 +60,7 @@ library hie-compat, hls-plugin-api >= 0.6, lens, + hiedb == 0.3.0.1, mtl, network-uri, parallel, @@ -73,6 +74,7 @@ library safe-exceptions, shake >= 0.18.4, sorted-list, + sqlite-simple, stm, syb, text, @@ -82,6 +84,9 @@ library utf8-string, vector, hslogger, + Diff, + vector, + bytestring-encoding, opentelemetry >=0.6.1, heapsize ==0.3.* if flag(ghc-lib) @@ -251,6 +256,8 @@ executable ghcide if flag(ghc-lib) buildable: False default-language: Haskell2010 + include-dirs: + include hs-source-dirs: exe ghc-options: -threaded @@ -264,6 +271,7 @@ executable ghcide "-with-rtsopts=-I0 -A128M" main-is: Main.hs build-depends: + hiedb, aeson, base == 4.*, data-default, @@ -271,6 +279,8 @@ executable ghcide extra, filepath, gitrev, + safe-exceptions, + ghc, hashable, haskell-lsp, haskell-lsp-types, @@ -337,7 +347,7 @@ test-suite ghcide-tests hls-plugin-api, network-uri, lens, - lsp-test >= 0.11.0.6 && < 0.12, + lsp-test >= 0.12.0.0 && < 0.13, optparse-applicative, process, QuickCheck, @@ -394,7 +404,7 @@ executable ghcide-bench extra, filepath, ghcide, - lsp-test >= 0.11.0.2 && < 0.12, + lsp-test >= 0.12.0.0 && < 0.13, optparse-applicative, process, safe-exceptions, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 11c4278059..1367422b42 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -8,6 +10,9 @@ module Development.IDE.Session ,defaultLoadingOptions ,loadSession ,loadSessionWithOptions + ,setInitialDynFlags + ,getHieDbLoc + ,runWithDb ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -72,6 +77,15 @@ import Control.Exception (evaluate) import Data.Void import Control.Applicative (Alternative((<|>))) +import HieDb.Create +import HieDb.Types +import HieDb.Utils +import Database.SQLite.Simple +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM (atomically) +import Maybes (MaybeT(runMaybeT)) +import HIE.Bios.Cradle (yamlConfig) + data CacheDirs = CacheDirs { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} @@ -92,6 +106,61 @@ defaultLoadingOptions = SessionLoadingOptions ,getCacheDirs = getCacheDirsDefault } +-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir +setInitialDynFlags :: IO (Maybe LibDir) +setInitialDynFlags = do + dir <- IO.getCurrentDirectory + hieYaml <- runMaybeT $ yamlConfig dir + cradle <- maybe (HieBios.loadImplicitCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + libDirRes <- getRuntimeGhcLibDir cradle + libdir <- case libDirRes of + CradleSuccess libdir -> pure $ Just $ LibDir libdir + CradleFail err -> do + hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle) + pure Nothing + CradleNone -> do + hPutStrLn stderr $ "Couldn't load cradle (CradleNone)" + pure Nothing + dynFlags <- mapM dynFlagsForPrinting libdir + mapM_ setUnsafeGlobalDynFlags dynFlags + pure libdir + +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial +-- by a worker thread using a dedicated database connection. +-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy +runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () +runWithDb fp k = do + -- Delete the database if it has an incompatible schema version + withHieDb fp (const $ pure ()) + `catch` \IncompatibleSchemaVersion{} -> removeFile fp + withHieDb fp $ \writedb -> do + initConn writedb + chan <- newTQueueIO + withAsync (writerThread writedb chan) $ \_ -> do + withHieDb fp (flip k chan) + where + writerThread db chan = do + -- Clear the index of any files that might have been deleted since the last run + deleteMissingRealFiles db + _ <- garbageCollectTypeNames db + forever $ do + k <- atomically $ readTQueue chan + k db + `catch` \e@SQLError{} -> do + hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e + `catchAny` \e -> do + hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e + + +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb" + dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) + -- | Given a root directory, return a Shake 'Action' which setups an -- 'IdeGhcSession' given a file. -- Some of the many things this does: @@ -731,8 +800,8 @@ notifyUserImplicitCradle fp = NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n\ - \You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." + ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <> + "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." notifyCradleLoaded :: FilePath -> FromServerMessage notifyCradleLoaded fp = diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index df9894ef5e..b34fff2c95 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -21,7 +21,8 @@ module Development.IDE.Core.Compile , generateObjectCode , generateByteCode , generateHieAsts - , writeHieFile + , writeAndIndexHieFile + , indexHieFile , writeHiFile , getModSummaryFromImports , loadHieFile @@ -37,11 +38,15 @@ import Development.IDE.Core.Preprocessor import Development.IDE.Core.Shake import Development.IDE.GHC.Error import Development.IDE.GHC.Warnings +import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Util import Development.IDE.Types.Options import Development.IDE.Types.Location +import Outputable hiding ((<>)) + +import HieDb import Language.Haskell.LSP.Types (DiagnosticTag(..)) @@ -68,7 +73,7 @@ import GhcPlugins as GHC hiding (fst3, (<>)) import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive) import MkIface import StringBuffer as SB -import TcRnMonad +import TcRnMonad hiding (newUnique) import TcIface (typecheckIface) import TidyPgm import Hooks @@ -100,6 +105,18 @@ import PrelNames import HeaderInfo import Maybes (orElse) +import qualified Data.HashMap.Strict as HashMap +import qualified Language.Haskell.LSP.Messages as LSP +import qualified Language.Haskell.LSP.Types as LSP +import Control.Concurrent.STM hiding (orElse) +import Control.Concurrent.Extra +import Data.Functor +import Data.Unique +import GHC.Fingerprint +import Data.Coerce +import Data.Aeson (toJSON) +import Data.Tuple.Extra (dupe) + -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions @@ -459,12 +476,135 @@ spliceExpresions Splices{..} = , DL.fromList $ map fst awSplices ] -writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] -writeHieFile hscEnv mod_summary exports ast source = +-- | In addition to indexing the `.hie` file, this function is responsible for +-- maintaining the 'IndexQueue' state and notfiying the user about indexing +-- progress. +-- +-- We maintain a record of all pending index operations in the 'indexPending' +-- TVar. +-- When 'indexHieFile' is called, it must check to ensure that the file hasn't +-- already be queued up for indexing. If it has, then we can just skip it +-- +-- Otherwise, we record the current file as pending and write an indexing +-- operation to the queue +-- +-- When the indexing operation is picked up and executed by the worker thread, +-- the first thing it does is ensure that a newer index for the same file hasn't +-- been scheduled by looking at 'indexPending'. If a newer index has been +-- scheduled, we can safely skip this one +-- +-- Otherwise, we start or continue a progress reporting session, telling it +-- about progress so far and the current file we are attempting to index. Then +-- we can go ahead and call in to hiedb to actually do the indexing operation +-- +-- Once this completes, we have to update the 'IndexQueue' state. First, we +-- must remove the just indexed file from 'indexPending' Then we check if +-- 'indexPending' is now empty. In that case, we end the progress session and +-- report the total number of file indexed. We also set the 'indexCompleted' +-- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we +-- can just increment the 'indexCompleted' TVar and exit. +-- +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () +indexHieFile se mod_summary srcPath hash hf = atomically $ do + pending <- readTVar indexPending + case HashMap.lookup srcPath pending of + Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled + _ -> do + modifyTVar' indexPending $ HashMap.insert srcPath hash + writeTQueue indexQueue $ \db -> do + -- We are now in the worker thread + -- Check if a newer index of this file has been scheduled, and if so skip this one + newerScheduled <- atomically $ do + pending <- readTVar indexPending + pure $ case HashMap.lookup srcPath pending of + Nothing -> False + -- If the hash in the pending list doesn't match the current hash, then skip + Just pendingHash -> pendingHash /= hash + unless newerScheduled $ do + tok <- pre + addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf + post tok + where + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + HieDbWriter{..} = hiedbWriter se + + -- Get a progress token to report progress and update it for the current file + pre = do + tok <- modifyVar indexProgressToken $ \case + x@(Just tok) -> pure (x, tok) + -- Create a token if we don't already have one + Nothing -> do + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique + lspId <- getLspId se + eventer se $ LSP.ReqWorkDoneProgressCreate $ + LSP.fmServerWorkDoneProgressCreateRequest lspId $ + LSP.WorkDoneProgressCreateParams { _token = u } + eventer se $ LSP.NotWorkDoneProgressBegin $ + LSP.fmServerWorkDoneProgressBeginNotification + LSP.ProgressParams + { _token = u + , _value = LSP.WorkDoneProgressBeginParams + { _title = "Indexing references from:" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + pure (Just u, u) + (!done, !remaining) <- atomically $ do + done <- readTVar indexCompleted + remaining <- HashMap.size <$> readTVar indexPending + pure (done, remaining) + let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." + eventer se $ LSP.NotWorkDoneProgressReport $ + LSP.fmServerWorkDoneProgressReportNotification + LSP.ProgressParams + { _token = tok + , _value = LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack (show srcPath) <> progress + , _percentage = Nothing + } + } + pure tok + + -- Report the progress once we are done indexing this file + post tok = do + mdone <- atomically $ do + -- Remove current element from pending + pending <- stateTVar indexPending $ + dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath + modifyTVar' indexCompleted (+1) + -- If we are done, report and reset completed + whenMaybe (HashMap.null pending) $ + swapTVar indexCompleted 0 + when (coerce $ ideTesting se) $ + eventer se $ LSP.NotCustomServer $ + LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath srcPath) + case mdone of + Nothing -> pure () + Just done -> + modifyVar_ indexProgressToken $ \_ -> do + eventer se $ LSP.NotWorkDoneProgressEnd $ + LSP.fmServerWorkDoneProgressEndNotification + LSP.ProgressParams + { _token = tok + , _value = LSP.WorkDoneProgressEndParams + { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" + } + } + -- We are done with the current indexing cycle, so destroy the token + pure Nothing + +writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] +writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = handleGenerationErrors dflags "extended interface write/compression" $ do hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source atomicFileWrite targetPath $ flip GHC.writeHieFile hf + hash <- getFileHash targetPath + indexHieFile se mod_summary srcPath hash hf where dflags = hsc_dflags hscEnv mod_location = ms_location mod_summary @@ -472,7 +612,7 @@ writeHieFile hscEnv mod_summary exports ast source = writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] writeHiFile hscEnv tc = - handleGenerationErrors dflags "interface generation" $ do + handleGenerationErrors dflags "interface write" $ do atomicFileWrite targetPath $ \fp -> writeIfaceFile dflags fp modIface where @@ -805,7 +945,7 @@ getDocsBatch hsc_env _mod _names = do else pure (Right ( Map.lookup name dmap , Map.findWithDefault Map.empty name amap)) case res of - Just x -> return $ map (first prettyPrint) x + Just x -> return $ map (first $ T.unpack . showGhc) x Nothing -> throwErrors errs where throwErrors = liftIO . throwIO . mkSrcErr diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 098fd97fd3..5ddb39d32f 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -6,6 +6,7 @@ module Development.IDE.Core.FileExists , modifyFileExists , getFileExists , watchedGlobs + , GetFileExists(..) ) where diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index f49ba759e2..2f87bd8d41 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -20,6 +20,8 @@ module Development.IDE.Core.FileStore( import Development.IDE.GHC.Orphans() import Development.IDE.Core.Shake import Control.Concurrent.Extra +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (writeTQueue) import qualified Data.Map.Strict as Map import qualified Data.HashMap.Strict as HM import Data.Maybe @@ -41,6 +43,7 @@ import Development.IDE.Types.Options import qualified Data.Rope.UTF16 as Rope import Development.IDE.Import.DependencyInformation import Ide.Plugin.Config (CheckParents(..)) +import HieDb.Create (deleteMissingRealFiles) #ifdef mingw32_HOST_OS import qualified System.Directory as Dir @@ -59,19 +62,6 @@ import qualified Development.IDE.Types.Logger as L import Language.Haskell.LSP.Core import Language.Haskell.LSP.VFS --- | haskell-lsp manages the VFS internally and automatically so we cannot use --- the builtin VFS without spawning up an LSP server. To be able to test things --- like `setBufferModified` we abstract over the VFS implementation. -data VFSHandle = VFSHandle - { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) - -- ^ get the contents of a virtual file - , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) - -- ^ set a specific file to a value. If Nothing then we are ignoring these - -- signals anyway so can just say something was modified - } - -instance IsIdeGlobal VFSHandle - makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) @@ -245,4 +235,6 @@ setSomethingModified state = do VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setSomethingModified can't be called on this type of VFSHandle" + -- Update database to remove any files that might have been renamed/deleted + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles void $ shakeRestart state [] diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ccd871f1ec..c046ae513f 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -25,7 +25,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import Data.Tuple.Extra import Development.Shake -import Control.Monad (void) +import Control.Monad import Development.IDE.Types.Exports import Development.IDE.Types.Location diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index 5cb867e853..adea5dc9b3 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -10,11 +10,13 @@ module Development.IDE.Core.PositionMapping , toCurrentPosition , PositionDelta(..) , addDelta + , idDelta , mkDelta , toCurrentRange , fromCurrentRange , applyChange , zeroMapping + , deltaFromDiff -- toCurrent and fromCurrent are mainly exposed for testing , toCurrent , fromCurrent @@ -24,6 +26,10 @@ import Control.Monad import qualified Data.Text as T import Language.Haskell.LSP.Types import Data.List +import Data.Algorithm.Diff +import Data.Bifunctor +import Control.DeepSeq +import qualified Data.Vector.Unboxed as V -- | Either an exact position, or the range of text that was substituted data PositionResult a @@ -64,6 +70,12 @@ data PositionDelta = PositionDelta , fromDelta :: !(Position -> PositionResult Position) } +instance Show PositionDelta where + show PositionDelta{} = "PositionDelta{..}" + +instance NFData PositionDelta where + rnf (PositionDelta a b) = a `seq` b `seq` () + fromCurrentPosition :: PositionMapping -> Position -> Maybe Position fromCurrentPosition (PositionMapping pm) = positionResultToMaybe . fromDelta pm @@ -158,3 +170,44 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine | line == newEndLine = column - (newEndColumn - endColumn) | otherwise = column newLine = line - lineDiff + +deltaFromDiff :: T.Text -> T.Text -> PositionDelta +deltaFromDiff (T.lines -> old) (T.lines -> new) = + PositionDelta (lookupPos lnew o2nPrevs o2nNexts old2new) (lookupPos lold n2oPrevs n2oNexts new2old) + where + !lnew = length new + !lold = length old + + diff = getDiff old new + + (V.fromList -> !old2new, V.fromList -> !new2old) = go diff 0 0 + + -- Compute previous and next lines that mapped successfully + !o2nPrevs = V.prescanl' f (-1) old2new + !o2nNexts = V.prescanr' (flip f) lnew old2new + + !n2oPrevs = V.prescanl' f (-1) new2old + !n2oNexts = V.prescanr' (flip f) lold new2old + + f :: Int -> Int -> Int + f !a !b = if b == -1 then a else b + + lookupPos :: Int -> V.Vector Int -> V.Vector Int -> V.Vector Int -> Position -> PositionResult Position + lookupPos end prevs nexts xs (Position line col) + | line < 0 = PositionRange (Position 0 0) (Position 0 0) + | line >= V.length xs = PositionRange (Position end 0) (Position end 0) + | otherwise = case V.unsafeIndex xs line of + -1 -> + -- look for the previous and next lines that mapped successfully + let !prev = 1 + V.unsafeIndex prevs line + !next = V.unsafeIndex nexts line + in PositionRange (Position prev 0) (Position next 0) + line' -> PositionExact (Position line' col) + + -- Construct a mapping between lines in the diff + -- -1 for unsucessful mapping + go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) + go [] _ _ = ([],[]) + go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1) + go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew + go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 93c37f65a4..d1e1d3d178 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -170,18 +171,30 @@ instance Show HiFileResult where -- | Save the uncompressed AST here, we compress it just before writing to disk data HieAstResult - = HAR + = forall a. HAR { hieModule :: Module - , hieAst :: !(HieASTs Type) - , refMap :: RefMap + , hieAst :: !(HieASTs a) + , refMap :: RefMap a -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same -- as that of `hieAst` + , typeRefs :: M.Map Name [RealSrcSpan] + -- ^ type references in this file + , hieKind :: !(HieKind a) + -- ^ Is this hie file loaded from the disk, or freshly computed? } -instance NFData HieAstResult where - rnf (HAR m hf _rm) = rnf m `seq` rwhnf hf +data HieKind a where + HieFromDisk :: !HieFile -> HieKind TypeIndex + HieFresh :: HieKind Type +instance NFData (HieKind a) where + rnf (HieFromDisk hf) = rnf hf + rnf HieFresh = () + +instance NFData HieAstResult where + rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind + instance Show HieAstResult where show = show . hieModule @@ -222,6 +235,10 @@ type instance RuleResult ReportImportCycles = () -- This is an internal rule, use 'GetModIface' instead. type instance RuleResult GetModIfaceFromDisk = HiFileResult +-- | GetModIfaceFromDisk and index the `.hie` file into the database. +-- This is an internal rule, use 'GetModIface' instead. +type instance RuleResult GetModIfaceFromDiskAndIndex = HiFileResult + -- | Get a module interface details, either from an interface file or a typechecked module type instance RuleResult GetModIface = HiFileResult @@ -392,6 +409,12 @@ instance Hashable GetModIfaceFromDisk instance NFData GetModIfaceFromDisk instance Binary GetModIfaceFromDisk +data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIfaceFromDiskAndIndex +instance NFData GetModIfaceFromDiskAndIndex +instance Binary GetModIfaceFromDiskAndIndex + data GetModIface = GetModIface deriving (Eq, Show, Typeable, Generic) instance Hashable GetModIface diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 31fdf4d352..ad17c04705 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -27,6 +27,8 @@ module Development.IDE.Core.Rules( getDefinition, getTypeDefinition, highlightAtPoint, + refsAtPoint, + workspaceSymbols, getDependencies, getParsedModule, getParsedModuleWithComments, @@ -60,7 +62,7 @@ module Development.IDE.Core.Rules( import Fingerprint -import Data.Aeson (fromJSON, Result(Success), FromJSON) +import Data.Aeson (fromJSON,toJSON, Result(Success), FromJSON) import Data.Binary hiding (get, put) import Data.Default import Data.Tuple.Extra @@ -97,7 +99,10 @@ import Development.Shake hiding (Diagnostic) import Development.IDE.Core.RuleTypes import qualified Data.ByteString.Char8 as BS import Development.IDE.Core.PositionMapping -import Language.Haskell.LSP.Types (DocumentHighlight (..)) +import Language.Haskell.LSP.Types (DocumentHighlight (..), SymbolInformation(..)) +import Language.Haskell.LSP.VFS +import qualified Language.Haskell.LSP.Messages as LSP +import qualified Language.Haskell.LSP.Types as LSP import qualified GHC.LanguageExtensions as LangExt import HscTypes hiding (TargetModule, TargetFile) @@ -108,14 +113,12 @@ import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.Shake.Classes hiding (get, put) -import Control.Monad.Trans.Except (runExceptT) -import Data.ByteString (ByteString) +import Control.Monad.Trans.Except (runExceptT,ExceptT,except) import Control.Concurrent.Async (concurrently) -import System.Time.Extra import Control.Monad.Reader -import System.Directory ( getModificationTime ) -import Control.Exception +import Control.Exception.Safe +import Data.Coerce import Control.Monad.State import FastString (FastString(uniq)) import qualified HeaderInfo as Hdr @@ -127,6 +130,11 @@ import TcRnMonad (tcg_dependent_files) import Data.IORef import Control.Concurrent.Extra import Module +import qualified Data.Rope.UTF16 as Rope +import GHC.IO.Encoding +import Data.ByteString.Encoding as T + +import qualified HieDb -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -150,97 +158,101 @@ defineNoFile f = define $ \k file -> do if file == emptyFilePath then do res <- f k; return ([], Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (ByteString, v)) -> Rules () +defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, ([], Just res)) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" - ------------------------------------------------------------ --- Exposed API +-- Core IDE features +------------------------------------------------------------ --- | Get all transitive file dependencies of a given module. --- Does not include the file itself. -getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) -getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file +-- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, +-- so we can quickly answer as soon as the IDE is opened +-- Even if we don't have persistent information on disk for these rules, the persistent rule +-- should just return an empty result +-- It is imperative that the result of the persistent rule succeed in such a case, or we will +-- block waiting for the rule to be properly computed. -- | Try to get hover text for the name under point. getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text])) -getAtPoint file pos = fmap join $ runMaybeT $ do +getAtPoint file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hieAst -> hf, mapping) <- useE GetHieAst file + (hf, mapping) <- useE GetHieAst file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - return $ AtPoint.atPoint opts hf dkMap pos' + MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos' + +toCurrentLocations :: PositionMapping -> [Location] -> [Location] +toCurrentLocations mapping = mapMaybe go + where + go (Location uri range) = Location uri <$> toCurrentRange mapping range -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location) +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ , mapping) <- useE GetHieAst file + (HAR _ hf _ _ _, mapping) <- useE GetHieAst file (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos' + hiedb <- lift $ asks hiedb + dbWriter <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod dbWriter) opts imports hf pos' getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hieAst -> hf, mapping) <- useE GetHieAst file + (hf, mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos' + hiedb <- lift $ asks hiedb + dbWriter <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod dbWriter) opts hf pos' highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf,mapping) <- useE GetHieAst file + (HAR _ hf rf _ _,mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - AtPoint.documentHighlight hf rf pos' - -getHieFile - :: ShakeExtras - -> NormalizedFilePath -- ^ file we're editing - -> Module -- ^ module dep we want info for - -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module -getHieFile ide file mod = do - TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file - case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of - Just NamedModuleDep{nmdFilePath=nfp} -> do - let modPath = fromNormalizedFilePath nfp - hieFile <- getHomeHieFile nfp - return (hieFile, modPath) - _ -> getPackageHieFile ide mod file - -getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile -getHomeHieFile f = do - ms <- fst . fst <$> useE GetModSummaryWithoutTimestamps f - let normal_hie_f = toNormalizedFilePath' hie_f - hie_f = ml_hie_file $ ms_location ms - - mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f) - srcTimestamp <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f)) - liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f) - let isUpToDate - | Just d <- mbHieTimestamp = d > srcTimestamp - | otherwise = False - - if isUpToDate - then do - ncu <- mkUpdater - hf <- liftIO $ whenMaybe isUpToDate (loadHieFile ncu hie_f) - MaybeT $ return hf - else do - wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do - hsc <- hscEnv <$> use_ GhcSession f - pm <- use_ GetParsedModule f - (_, mtm)<- typeCheckRuleDefinition hsc pm - mapM_ (getHieAstRuleDefinition f hsc) mtm -- Write the HiFile to disk - _ <- MaybeT $ liftIO $ timeout 1 wait - ncu <- mkUpdater - liftIO $ loadHieFile ncu hie_f + let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range + mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' + +-- Refs are not an IDE action, so it is OK to be slow and (more) accurate +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint file pos = do + ShakeExtras{hiedb} <- getShakeExtras + fs <- HM.keys <$> getFilesOfInterest + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts) + +workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) +workspaceSymbols query = runMaybeT $ do + hiedb <- lift $ asks hiedb + res <- liftIO $ HieDb.searchDef hiedb $ T.unpack query + pure $ mapMaybe AtPoint.defRowToSymbolInfo res + +------------------------------------------------------------ +-- Exposed API +------------------------------------------------------------ + +-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the +-- project. Right now, this is just a stub. +lookupMod + :: HieDbWriter -- ^ access the database + -> FilePath -- ^ The `.hie` file we got from the database + -> ModuleName + -> UnitId + -> Bool -- ^ Is this file a boot file? + -> MaybeT IdeAction Uri +lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing + +-- | Get all transitive file dependencies of a given module. +-- Does not include the file itself. +getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) +getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do @@ -249,28 +261,6 @@ getSourceFileSource nfp = do Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) Just source -> pure $ T.encodeUtf8 source -getPackageHieFile :: ShakeExtras - -> Module -- ^ Package Module to load .hie file for - -> NormalizedFilePath -- ^ Path of home module importing the package module - -> MaybeT IdeAction (HieFile, FilePath) -getPackageHieFile ide mod file = do - pkgState <- hscEnv . fst <$> useE GhcSession file - IdeOptions {..} <- liftIO $ getIdeOptionsIO ide - let unitId = moduleUnitId mod - case lookupPackageConfig unitId pkgState of - Just pkgConfig -> do - -- 'optLocateHieFile' returns Nothing if the file does not exist - hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod - path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod - case (hieFile, path) of - (Just hiePath, Just modPath) -> do - -- deliberately loaded outside the Shake graph - -- to avoid dependencies on non-workspace files - ncu <- mkUpdater - MaybeT $ liftIO $ Just . (, modPath) <$> loadHieFile ncu hiePath - _ -> MaybeT $ return Nothing - _ -> MaybeT $ return Nothing - -- | Parse the contents of a haskell file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) getParsedModule = use GetParsedModule @@ -374,7 +364,7 @@ getParsedModuleWithCommentsRule = defineEarlyCutoff $ \GetParsedModuleWithCommen liftIO $ getParsedModuleDefinition (hscEnv sess) opt file ms' -getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) +getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe BS.ByteString, ([FileDiagnostic], Maybe ParsedModule)) getParsedModuleDefinition packageState opt file ms = do let fp = fromNormalizedFilePath file (diag, res) <- parseModule opt packageState fp ms @@ -578,32 +568,60 @@ getHieAstsRule = hsc <- hscEnv <$> use_ GhcSession f getHieAstRuleDefinition f hsc tmr +persistentHieFileRule :: Rules () +persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk file + vfs <- asks vfs + encoding <- liftIO getLocaleEncoding + (currentSource,ver) <- liftIO $ do + mvf <- getVirtualFile vfs $ filePathToUri' file + case mvf of + Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) + Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) + let refmap = generateReferencesMap . getAsts . hie_asts $ res + del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource + pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver) + getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do (diags, masts) <- liftIO $ generateHieAsts hsc tmr + se <- getShakeExtras isFoi <- use_ IsFileOfInterest f diagsWrite <- case isFoi of - IsFOI Modified -> pure [] + IsFOI Modified -> do + when (coerce $ ideTesting se) $ + liftIO $ eventer se $ LSP.NotCustomServer $ + LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + pure [] _ | Just asts <- masts -> do source <- getSourceFileSource f - liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source + let exports = tcg_exports $ tmrTypechecked tmr + msum = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se msum f exports asts source _ -> pure [] let refmap = generateReferencesMap . getAsts <$> masts - pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap) + typemap = AtPoint.computeTypeReferences . getAsts <$> masts + pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) -getImportMapRule :: Rules() +getImportMapRule :: Rules () getImportMapRule = define $ \GetImportMap f -> do im <- use GetLocatedImports f let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports pure ([], ImportMap . mkImports <$> im) +-- | Ensure that go to definition doesn't block on startup +persistentImportMapRule :: Rules () +persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) + getBindingsRule :: Rules () getBindingsRule = define $ \GetBindings f -> do - har <- use_ GetHieAst f - pure ([], Just $ bindings $ refMap har) + HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f + case kind of + HieFresh -> pure ([], Just $ bindings rm) + HieFromDisk _ -> pure ([], Nothing) getDocMapRule :: Rules () getDocMapRule = @@ -612,7 +630,7 @@ getDocMapRule = -- but we never generated a DocMap for it (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file - (refMap -> rf, _) <- useWithStale_ GetHieAst file + (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file -- When possible, rely on the haddocks embedded in our interface files -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' @@ -627,7 +645,30 @@ getDocMapRule = dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc return ([],Just dkMap) --- Typechecks a module. +-- | Persistent rule to ensure that hover doesn't block on startup +persistentDocMapRule :: Rules () +persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) + +readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile +readHieFileForSrcFromDisk file = do + db <- asks hiedb + log <- asks $ L.logDebug . logger + row <- MaybeT $ liftIO $ HieDb.lookupHieFileFromSource db $ fromNormalizedFilePath file + let hie_loc = HieDb.hieModuleHieFile row + liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) + exceptToMaybeT $ readHieFileFromDisk hie_loc + +readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile +readHieFileFromDisk hie_loc = do + nc <- asks ideNc + log <- asks $ L.logInfo . logger + res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc + liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + res + except res + +-- | Typechecks a module. typeCheckRule :: Rules () typeCheckRule = define $ \TypeCheck file -> do pm <- use_ GetParsedModule file @@ -659,7 +700,6 @@ typeCheckRuleDefinition hsc pm = do IdeOptions { optDefer = defer } <- getIdeOptions linkables_to_keep <- currentLinkables - addUsageDependencies $ liftIO $ typecheckModule defer hsc linkables_to_keep pm where @@ -741,21 +781,64 @@ ghcSessionDepsDefinition file = do res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' [] return ([], Just res) +-- | Load a iface from disk, or generate it if there isn't one or it is out of date +-- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. getModIfaceFromDiskRule :: Rules () getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do (ms,_) <- use_ GetModSummary f (diags_session, mb_session) <- ghcSessionDepsDefinition f case mb_session of - Nothing -> return (Nothing, (diags_session, Nothing)) - Just session -> do - sourceModified <- use_ IsHiFileStable f - linkableType <- getLinkableType f - r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) - case r of - (diags, Just x) -> do - let fp = Just (hiFileFingerPrint x) - return (fp, (diags <> diags_session, Just x)) - (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) + Nothing -> return (Nothing, (diags_session, Nothing)) + Just session -> do + sourceModified <- use_ IsHiFileStable f + linkableType <- getLinkableType f + r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms) + case r of + (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) + (diags, Just x) -> do + let !fp = Just $! hiFileFingerPrint x + return (fp, (diags <> diags_session, Just x)) + +-- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file? +-- This function is responsible for ensuring database consistency +-- Whenever we read a `.hi` file, we must check to ensure we have also +-- indexed the corresponding `.hie` file. If this is not the case (for example, +-- `ghcide` could be killed before indexing finishes), we must re-index the +-- `.hie` file. There should be an up2date `.hie` file on +-- disk since we are careful to write out the `.hie` file before writing the +-- `.hi` file +getModIfaceFromDiskAndIndexRule :: Rules () +getModIfaceFromDiskAndIndexRule = defineEarlyCutoff $ \GetModIfaceFromDiskAndIndex f -> do + x <- use_ GetModIfaceFromDisk f + se@ShakeExtras{hiedb} <- getShakeExtras + + -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db + let ms = hirModSummary x + hie_loc = ml_hie_file $ ms_location ms + hash <- liftIO $ getFileHash hie_loc + mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) + case mrow of + Just row + | hash == HieDb.modInfoHash (HieDb.hieModInfo row) + , hie_loc == HieDb.hieModuleHieFile row -> do + -- All good, the db has indexed the file + when (coerce $ ideTesting se) $ + liftIO $ eventer se $ LSP.NotCustomServer $ + LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f) + -- Not in db, must re-index + _ -> do + ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ + readHieFileFromDisk hie_loc + case ehf of + -- Uh oh, we failed to read the file for some reason, need to regenerate it + Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err + -- can just re-index the file we read from disk + Right hf -> liftIO $ do + L.logInfo (logger se) $ "Re-indexing hie file for" <> T.pack (show f) + indexHieFile se ms f hash hf + + let fp = hiFileFingerPrint x + return (Just fp, ([], Just x)) isHiFileStableRule :: Rules () isHiFileStableRule = defineEarlyCutoff $ \IsHiFileStable f -> do @@ -855,7 +938,7 @@ getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do _ -> pure [] return (fp, (diags++hiDiags, hiFile)) NotFOI -> do - hiFile <- use GetModIfaceFromDisk f + hiFile <- use GetModIfaceFromDiskAndIndex f let fp = hiFileFingerPrint <$> hiFile return (fp, ([], hiFile)) @@ -879,6 +962,9 @@ getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr')) +-- | Also generates and indexes the `.hie` file, along with the `.o` file if needed +-- Invariant maintained is that if the `.hi` file was successfully written, then the +-- `.hie` and `.o` file (if needed) were also successfully written regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) regenerateHiFile sess f ms compNeeded = do let hsc = hscEnv sess @@ -910,18 +996,28 @@ regenerateHiFile sess f ms compNeeded = do -- Write hi file hiDiags <- case res of - Just hiFile - | not $ tmrDeferedError tmr -> - liftIO $ writeHiFile hsc hiFile - _ -> pure [] + Just !hiFile -> do + + -- Write hie file. Do this before writing the .hi file to + -- ensure that we always have a up2date .hie file if we have + -- a .hi file + se <- getShakeExtras + (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr + source <- getSourceFileSource f + wDiags <- forM masts $ \asts -> + liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + + -- We don't write the `.hi` file if there are defered errors, since we won't get + -- accurate diagnostics next time if we do + hiDiags <- if not $ tmrDeferedError tmr + then liftIO $ writeHiFile hsc hiFile + else pure [] + + pure (hiDiags <> gDiags <> concat wDiags) + Nothing -> pure [] - -- Write hie file - (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr - source <- getSourceFileSource f - wDiags <- forM masts $ \asts -> - liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source - return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res) + return (diags <> diags' <> diags'' <> hiDiags, res) type CompileMod m = m (IdeResult ModGuts) @@ -1009,6 +1105,7 @@ mainRule = do getDocMapRule loadGhcSession getModIfaceFromDiskRule + getModIfaceFromDiskAndIndexRule getModIfaceRule getModIfaceWithoutLinkableRule getModSummaryRule @@ -1022,6 +1119,9 @@ mainRule = do generateCoreRule getImportMapRule getAnnotatedParsedSourceRule + persistentHieFileRule + persistentDocMapRule + persistentImportMapRule -- | Given the path to a module src file, this rule returns True if the -- corresponding `.hi` file is stable, that is, if it is newer diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 9701cd07e8..f2f19fc319 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -20,7 +20,7 @@ module Development.IDE.Core.Service( import Development.IDE.Types.Options (IdeOptions(..)) import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules) +import Development.IDE.Core.FileStore (fileStoreRules) import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger @@ -33,7 +33,6 @@ import Development.IDE.Core.Shake import Control.Monad - ------------------------------------------------------------ -- Exposed API @@ -48,8 +47,10 @@ initialise :: LSP.ClientCapabilities -> Debouncer LSP.NormalizedUri -> IdeOptions -> VFSHandle + -> HieDb + -> IndexQueue -> IO IdeState -initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs = +initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs hiedb hiedbChan = shakeOpen getLspId toDiags @@ -61,6 +62,9 @@ initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer opti (optShakeProfiling options) (optReportProgress options) (optTesting options) + hiedb + hiedbChan + vfs (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0ca0f1172e..4ec054b60b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -36,6 +36,7 @@ module Development.IDE.Core.Shake( use_, useNoFile_, uses_, useWithStale, usesWithStale, useWithStale_, usesWithStale_, + BadDependency(..), define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, getHiddenDiagnostics, @@ -62,6 +63,11 @@ module Development.IDE.Core.Shake( mkUpdater, -- Exposed for testing. Q(..), + IndexQueue, + HieDb, + HieDbWriter(..), + VFSHandle(..), + addPersistentRule ) where import Development.Shake hiding (ShakeValue, doesFileExist, Info) @@ -99,7 +105,7 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import Control.Concurrent.Async import Control.Concurrent.Extra -import Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, atomically) +import Control.Concurrent.STM import Control.DeepSeq import Control.Exception.Extra import System.Time.Extra @@ -121,6 +127,7 @@ import Control.Monad.Trans.Maybe import Data.Traversable import Data.Hashable import Development.IDE.Core.Tracing +import Language.Haskell.LSP.VFS import Data.IORef import NameCache @@ -128,6 +135,24 @@ import UniqSupply import PrelInfo import Language.Haskell.LSP.Types.Capabilities import OpenTelemetry.Eventlog +import GHC.Fingerprint + +import HieDb.Types + +-- | We need to serialize writes to the database, so we send any function that +-- needs to write to the database over the channel, where it will be picked up by +-- a worker thread. +data HieDbWriter + = HieDbWriter + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress + , indexProgressToken :: Var (Maybe LSP.ProgressToken) + -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + } + +-- | Actions to queue up on the index worker thread +type IndexQueue = TQueue (HieDb -> IO ()) -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -167,6 +192,13 @@ data ShakeExtras = ShakeExtras -- | A work queue for actions added via 'runInShakeSession' ,actionQueue :: ActionQueue ,clientCapabilities :: ClientCapabilities + , hiedb :: HieDb -- ^ Use only to read. + , hiedbWriter :: HieDbWriter -- ^ use to write + , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent) + -- ^ Registery for functions that compute/get "stale" results for the rule + -- (possibly from disk) + , getLspId :: IO LspId + , vfs :: VFSHandle } type WithProgressFunc = forall a. @@ -178,6 +210,8 @@ data ProgressEvent = KickStarted | KickCompleted +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) + getShakeExtras :: Action ShakeExtras getShakeExtras = do Just x <- getShakeExtra @ShakeExtras @@ -188,8 +222,32 @@ getShakeExtrasRules = do Just x <- getShakeExtraRules @ShakeExtras return x +-- | Register a function that will be called to get the "stale" result of a rule, possibly from disk +-- This is called when we don't already have a result, or computing the rule failed. +-- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will +-- be queued if the rule hasn't run before. +addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () +addPersistentRule k getVal = do + ShakeExtras{persistentKeys} <- getShakeExtrasRules + liftIO $ modifyVar_ persistentKeys $ \hm -> do + pure $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) hm + return () + class Typeable a => IsIdeGlobal a where + +-- | haskell-lsp manages the VFS internally and automatically so we cannot use +-- the builtin VFS without spawning up an LSP server. To be able to test things +-- like `setBufferModified` we abstract over the VFS implementation. +data VFSHandle = VFSHandle + { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile) + -- ^ get the contents of a virtual file + , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ()) + -- ^ set a specific file to a value. If Nothing then we are ignoring these + -- signals anyway so can just say something was modified + } +instance IsIdeGlobal VFSHandle + addIdeGlobal :: IsIdeGlobal a => a -> Rules () addIdeGlobal x = do extras <- getShakeExtrasRules @@ -234,26 +292,54 @@ getIdeOptionsIO ide = do -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping)) -lastValueIO ShakeExtras{positionMapping} file v = do - allMappings <- liftIO $ readVar positionMapping - pure $ case v of - Succeeded ver v -> Just (v, mappingForVersion allMappings file ver) - Stale ver v -> Just (v, mappingForVersion allMappings file ver) - Failed -> Nothing +lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping)) +lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do + hm <- readVar state + allMappings <- readVar positionMapping + + let readPersistent + | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests + , testing = pure Nothing + | otherwise = do + pmap <- readVar persistentKeys + mv <- runMaybeT $ do + liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP UP PERSISTENT FOR: " ++ show k + f <- MaybeT $ pure $ HMap.lookup (Key k) pmap + (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file + MaybeT $ pure $ (,del,ver) <$> fromDynamic dv + modifyVar state $ \hm -> pure $ case mv of + Nothing -> (HMap.alter (alterValue $ Failed True) (file,Key k) hm,Nothing) + Just (v,del,ver) -> (HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) hm + ,Just (v,addDelta del $ mappingForVersion allMappings file ver)) + + -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics + alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics + alterValue new (Just old@(ValueWithDiagnostics val diags)) = Just $ case val of + -- Old failed, we can update it preserving diagnostics + Failed{} -> ValueWithDiagnostics new diags + -- Something already succeeded before, leave it alone + _ -> old + + case HMap.lookup (file,Key k) hm of + Nothing -> readPersistent + Just (ValueWithDiagnostics v _) -> case v of + Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) + Stale del ver (fromDynamic -> Just v) -> pure (Just (v, maybe id addDelta del $ mappingForVersion allMappings file ver)) + Failed p | not p -> readPersistent + _ -> pure Nothing -- | Return the most recent, potentially stale, value and a PositionMapping -- for the version of that value. -lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping)) -lastValue file v = do +lastValue :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) +lastValue key file = do s <- getShakeExtras - liftIO $ lastValueIO s file v + liftIO $ lastValueIO s key file valueVersion :: Value v -> Maybe TextDocumentVersion valueVersion = \case Succeeded ver _ -> Just ver - Stale ver _ -> Just ver - Failed -> Nothing + Stale _ ver _ -> Just ver + Failed _ -> Nothing mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) @@ -362,8 +448,8 @@ knownTargets = do seqValue :: Value v -> b -> b seqValue v b = case v of Succeeded ver v -> rnf ver `seq` v `seq` b - Stale ver v -> rnf ver `seq` v `seq` b - Failed -> b + Stale d ver v -> rnf d `seq` rnf ver `seq` v `seq` b + Failed _ -> b -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: IO LSP.LspId @@ -376,12 +462,14 @@ shakeOpen :: IO LSP.LspId -> Maybe FilePath -> IdeReportProgress -> IdeTesting + -> HieDb + -> IndexQueue + -> VFSHandle -> ShakeOptions -> Rules () -> IO IdeState shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo - + shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -396,7 +484,12 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilitie let restartShakeSession = shakeRestart ideState let session = shakeSession mostRecentProgressEvent <- newTVarIO KickCompleted + persistentKeys <- newVar HMap.empty let progressUpdate = atomically . writeTVar mostRecentProgressEvent + indexPending <- newTVarIO HMap.empty + indexCompleted <- newTVarIO 0 + indexProgressToken <- newVar Nothing + let hiedbWriter = HieDbWriter{..} progressAsync <- async $ when reportProgress $ progressThread mostRecentProgressEvent inProgress @@ -718,10 +811,8 @@ runIdeAction _herald s i = runReaderT (runIdeActionT i) s askShake :: IdeAction ShakeExtras askShake = ask -mkUpdater :: MaybeT IdeAction NameCacheUpdater -mkUpdater = do - ref <- lift $ ideNc <$> askShake - pure $ NCU (upNameCache ref) +mkUpdater :: IORef NameCache -> NameCacheUpdater +mkUpdater ref = NCU (upNameCache ref) -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } @@ -748,16 +839,16 @@ useWithStaleFast' key file = do liftIO $ case r of -- block for the result if we haven't computed before Nothing -> do - a <- wait - r <- getValues state key file - case r of - Nothing -> return $ FastResult Nothing (pure a) - Just (v, _) -> do - res <- lastValueIO s file v - pure $ FastResult res (pure a) + -- Check if we can get a stale value from disk + res <- lastValueIO s key file + case res of + Nothing -> do + a <- wait + pure $ FastResult ((,zeroMapping) <$> a) (pure a) + Just _ -> pure $ FastResult res wait -- Otherwise, use the computed value even if it's out of date. - Just (v, _) -> do - res <- lastValueIO s file v + Just _ -> do + res <- lastValueIO s key file pure $ FastResult res wait useNoFile :: IdeRule k v => k -> Action (Maybe v) @@ -785,8 +876,11 @@ uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key usesWithStale :: IdeRule k v => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] usesWithStale key files = do - values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files) - zipWithM lastValue files values + _ <- apply (map (Q . (key,)) files) + -- We don't look at the result of the 'apply' since 'lastValue' will + -- return the most recent successfully computed value regardless of + -- whether the rule succeeded or not. + mapM (lastValue key) files -- | Define a new Rule with early cutoff defineEarlyCutoff @@ -819,14 +913,14 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old Nothing -> do staleV <- liftIO $ getValues state key file pure $ case staleV of - Nothing -> (toShakeValue ShakeResult bs, Failed) + Nothing -> (toShakeValue ShakeResult bs, Failed False) Just v -> case v of (Succeeded ver v, _) -> - (toShakeValue ShakeStale bs, Stale ver v) - (Stale ver v, _) -> - (toShakeValue ShakeStale bs, Stale ver v) - (Failed, _) -> - (toShakeValue ShakeResult bs, Failed) + (toShakeValue ShakeStale bs, Stale Nothing ver v) + (Stale d ver v, _) -> + (toShakeValue ShakeStale bs, Stale d ver v) + (Failed b, _) -> + (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) liftIO $ setValues state key file res (Vector.fromList diags) updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags @@ -849,7 +943,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x isSuccess :: RunResult (A v) -> Bool -isSuccess (RunResult _ _ (A Failed)) = False +isSuccess (RunResult _ _ (A Failed{})) = False isSuccess _ = True -- | Rule type, input file diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 1a72edba53..dcb4e4db94 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -42,6 +42,7 @@ module Development.IDE.GHC.Compat( disableWarningsAsErrors, AvailInfo, tcg_exports, + pattern FunTy, #if MIN_GHC_API_VERSION(8,10,0) module GHC.Hs.Extension, @@ -89,6 +90,7 @@ import HsExtension #endif import qualified GHC +import qualified TyCoRep import GHC hiding ( ModLocation, HasSrcSpan, @@ -151,7 +153,7 @@ upNameCache = updNameCache #endif -type RefMap = Map Identifier [(Span, IdentifierDetails Type)] +type RefMap a = Map Identifier [(Span, IdentifierDetails a)] mkHieFile' :: ModSummary -> [AvailInfo] @@ -292,3 +294,9 @@ dropForAll = snd . GHC.splitLHsForAllTyInvis dropForAll = snd . GHC.splitLHsForAllTy #endif +pattern FunTy :: Type -> Type -> Type +#if MIN_GHC_API_VERSION(8, 10, 0) +pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#else +pattern FunTy arg res <- TyCoRep.FunTy arg res +#endif diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index 14caa1174c..bce5cc733f 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -15,6 +15,7 @@ module Development.IDE.GHC.Error , srcSpanToRange , realSrcSpanToRange , realSrcLocToPosition + , realSrcSpanToLocation , srcSpanToFilename , zeroSpan , realSpan @@ -90,6 +91,10 @@ srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +realSrcSpanToLocation :: RealSrcSpan -> Location +realSrcSpanToLocation real = Location file (realSrcSpanToRange real) + where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real + srcSpanToLocation :: SrcSpan -> Maybe Location srcSpanToLocation src = do fs <- srcSpanToFilename src diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 6213e23a03..3650ac29e5 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -13,6 +14,7 @@ module Development.IDE.GHC.Util( deps, -- * GHC wrappers prettyPrint, + unsafePrintSDoc, printRdrName, printName, ParseResult(..), runParser, @@ -41,6 +43,7 @@ import Data.Typeable import qualified Data.ByteString.Internal as BS import Fingerprint import GhcMonad +import DynFlags import Control.Exception import Data.IORef import FileCleanup @@ -64,7 +67,7 @@ import StringBuffer import System.FilePath import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags)) import PackageConfig (PackageConfig) -import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable) +import Outputable (SDoc, showSDocUnsafe, ppr, Outputable, mkUserStyle, renderWithStyle, neverQualify, Depth(..)) import Packages (getPackageConfigMap, lookupPackage') import SrcLoc (mkRealSrcLoc) import FastString (mkFastString) @@ -122,7 +125,12 @@ bytestringToStringBuffer (PS buf cur len) = StringBuffer{..} -- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. prettyPrint :: Outputable a => a -> String -prettyPrint = showSDoc unsafeGlobalDynFlags . ppr +prettyPrint = unsafePrintSDoc . ppr + +unsafePrintSDoc :: SDoc -> String +unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay) + where + dflags = unsafeGlobalDynFlags -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs index 3c591abd2c..f4c0793a6d 100644 --- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs +++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs @@ -10,7 +10,7 @@ module Development.IDE.Import.DependencyInformation , TransitiveDependencies(..) , FilePathId(..) , NamedModuleDep(..) - + , ShowableModuleName(..) , PathIdMap , emptyPathIdMap , getPathId diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 4811745014..aca02256fb 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -6,6 +6,7 @@ module Development.IDE.Import.FindImports ( locateModule + , locateModuleFile , Import(..) , ArtifactsLocation(..) , modSummaryToArtifactsLocation diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 3df7cda806..8a09b5a3f3 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -7,6 +7,8 @@ module Development.IDE.LSP.HoverDefinition ( setHandlersDefinition , setHandlersTypeDefinition , setHandlersDocHighlight + , setHandlersReferences + , setHandlersWsSymbols -- * For haskell-language-server , hover , gotoDefinition @@ -28,22 +30,43 @@ gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseE hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams) documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc +gotoDefinition = request "Definition" getDefinition (MultiLoc []) MultiLoc gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc hover = request "Hover" getAtPoint Nothing foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List +references :: IdeState -> ReferenceParams -> IO (Either ResponseError (List Location)) +references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _) = + case uriToFilePath' uri of + Just path -> do + let filePath = toNormalizedFilePath' path + logDebug (ideLogger ide) $ + "References request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) + Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing + +wsSymbols :: IdeState -> WorkspaceSymbolParams -> IO (Either ResponseError (List SymbolInformation)) +wsSymbols ide (WorkspaceSymbolParams query _) = do + logDebug (ideLogger ide) $ "Workspace symbols request: " <> query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query + foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c +setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight, + setHandlersReferences, setHandlersWsSymbols :: PartialHandlers c setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x -> return x {LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition} setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x -> return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight} +setHandlersReferences = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.referencesHandler = withResponse RspFindReferences $ const references} +setHandlersWsSymbols = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.workspaceSymbolHandler = withResponse RspWorkspaceSymbols $ const wsSymbols} -- | Respond to and log a hover or go-to-definition request request diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 27747071c0..a4972f6873 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -109,7 +109,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat initializeRequestHandler <> setHandlersIgnore <> -- least important setHandlersDefinition <> setHandlersTypeDefinition <> - setHandlersDocHighlight <> + setHandlersDocHighlight <> setHandlersReferences <> setHandlersWsSymbols <> setHandlersOutline <> userHandlers <> setHandlersNotifications <> -- absolutely critical, join them with user notifications diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index 0bbc0ae387..a129267975 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -22,7 +22,8 @@ import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri ( import Development.IDE.Core.Service import Data.Aeson (Value) import Development.IDE.Core.Tracing (otSetUri) -import OpenTelemetry.Eventlog (SpanInFlight) +import OpenTelemetry.Eventlog (SpanInFlight, setTag) +import Data.Text.Encoding (encodeUtf8) data WithMessage c = WithMessage {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) => @@ -68,6 +69,8 @@ instance HasTracing DidChangeWorkspaceFoldersParams instance HasTracing DidChangeConfigurationParams instance HasTracing InitializeParams instance HasTracing (Maybe InitializedParams) +instance HasTracing WorkspaceSymbolParams where + traceWithSpan sp (WorkspaceSymbolParams query _) = setTag sp "query" (encodeUtf8 query) setUriAnd :: (HasTextDocument params a, HasUri a Uri) => diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index cea837eee3..97ab78896e 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -188,7 +188,7 @@ mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..} compKind = occNameToComKind typeText $ occName origName importedFrom = Right $ showModName origMod isTypeCompl = isTcOcc $ occName origName - label = T.pack $ showGhc origName + label = showGhc origName insertText = case isInfix of Nothing -> case getArgText <$> thingType of Nothing -> label @@ -197,7 +197,7 @@ mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..} Just Surrounded -> label typeText - | Just t <- thingType = Just . stripForall $ T.pack (showGhc t) + | Just t <- thingType = Just . stripForall $ showGhc t | otherwise = Nothing additionalTextEdits = imp >>= extendImportList (showGhc origName) @@ -215,7 +215,7 @@ mkNameCompItem origName origMod thingType isInfix docs !imp = CI{..} argText :: T.Text argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes snippet :: Int -> Type -> T.Text - snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" + snippet i t = "${" <> T.pack (show i) <> ":" <> showGhc t <> "}" getArgs :: Type -> [Type] getArgs t | isPredTy t = [] @@ -261,21 +261,21 @@ mkPragmaCompl label insertText = Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing -extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit] +extendImportList :: T.Text -> LImportDecl GhcPs -> Maybe [TextEdit] extendImportList name lDecl = let f (Just range) ImportDecl {ideclHiding} = case ideclHiding of Just (False, x) - | Set.notMember name (Set.fromList [show y| y <- unLoc x]) + | Set.notMember name (Set.fromList [T.pack (show y) | y <- unLoc x]) -> let start_pos = _end range new_start_pos = start_pos {_character = _character start_pos - 1} -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules new_range = Range new_start_pos new_start_pos -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$) - alpha = all isAlphaNum $ filter (/= '_') name - result = if alpha then name ++ ", " - else "(" ++ name ++ "), " - in Just [TextEdit new_range (T.pack result)] + alpha = T.all isAlphaNum $ T.filter (\c -> c /= '_') name + result = if alpha then name <> ", " + else "(" <> name <> "), " + in Just [TextEdit new_range result] | otherwise -> Nothing _ -> Nothing -- hiding import list and no list f _ _ = Nothing @@ -417,11 +417,11 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{ findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result where - result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing + result = [mkRecordSnippetCompItem (showGhc . unLoc $ con_name) field_labels mn doc Nothing | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn , Just con_details <- [getFlds con_args] , let field_names = mapMaybe extract con_details - , let field_labels = T.pack . showGhc . unLoc <$> field_names + , let field_labels = showGhc . unLoc <$> field_names , (not . List.null) field_labels ] doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) @@ -698,7 +698,7 @@ prefixes = safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text]) safeTyThingForRecord (AnId _) = Nothing safeTyThingForRecord (AConLike dc) = - let ctxStr = T.pack . showGhc . occName . conLikeName $ dc + let ctxStr = showGhc . occName . conLikeName $ dc field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc in Just (ctxStr, field_names) @@ -716,7 +716,7 @@ mkRecordSnippetCompItem ctxStr compl mn docs imp = r , isInfix = Nothing , docs = docs , isTypeCompl = False - , additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr) + , additionalTextEdits = imp >>= extendImportList ctxStr } placeholder_pairs = zip compl ([1..]::[Int]) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index bb33a3f856..d66f722096 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -1,6 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" + -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. module Development.IDE.Spans.AtPoint ( @@ -9,28 +13,34 @@ module Development.IDE.Spans.AtPoint ( , gotoTypeDefinition , documentHighlight , pointCommand + , referencesAtPoint + , computeTypeReferences + , FOIReferences(..) + , defRowToSymbolInfo ) where -import Development.IDE.GHC.Error +import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location -import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types --- DAML compiler and infrastructure +-- compiler and infrastructure import Development.IDE.GHC.Compat import Development.IDE.Types.Options import Development.IDE.Spans.Common import Development.IDE.Core.RuleTypes +import Development.IDE.Core.PositionMapping -- GHC API imports -import FastString import Name import Outputable hiding ((<>)) import SrcLoc -import TyCoRep +import TyCoRep hiding (FunTy) import TyCon import qualified Var import NameEnv +import IfaceType +import FastString (unpackFS) import Control.Applicative import Control.Monad.Extra @@ -38,20 +48,112 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Maybe -import Data.List import qualified Data.Text as T -import qualified Data.Map as M +import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as HM +import qualified Data.Array as A import Data.Either -import Data.List.Extra (dropEnd1) +import Data.List.Extra (nubOrd, dropEnd1) +import Data.List (isSuffixOf) + +import HieDb hiding (pointCommand) + +-- | Gives a Uri for the module, given the .hie file location and the the module info +-- The Bool denotes if it is a boot module +type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri + +-- | HieFileResult for files of interest, along with the position mappings +newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) + +computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span] +computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = M.fromListWith (++) + $ map (, [nodeSpan ast]) + $ concatMap namesInType + $ mapMaybe (\x -> guard (not $ all isOccurrence $ identInfo x) *> identType x) + $ M.elems + $ nodeIdentifiers $ nodeInfo ast + +-- | Given a file and position, return the names at a point, the references for +-- those names in the FOIs, and a list of file paths we already searched through +foiReferencesAtPoint + :: NormalizedFilePath + -> Position + -> FOIReferences + -> ([Name],[Location],[FilePath]) +foiReferencesAtPoint file pos (FOIReferences asts) = + case HM.lookup file asts of + Nothing -> ([],[],[]) + Just (HAR _ hf _ _ _,mapping) -> + let posFile = fromMaybe pos $ fromCurrentPosition mapping pos + names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + adjustedLocs = HM.foldr go [] asts + go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs + where + refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) + $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names + typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) + $ concat $ mapMaybe (`M.lookup` tr) names + toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range + in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) + +referencesAtPoint + :: MonadIO m + => HieDb + -> NormalizedFilePath -- ^ The file the cursor is in + -> Position -- ^ position in the file + -> FOIReferences -- ^ references data for FOIs + -> m [Location] +referencesAtPoint hiedb nfp pos refs = do + -- The database doesn't have up2date references data for the FOIs so we must collect those + -- from the Shake graph. + let (names, foiRefs, exclude) = foiReferencesAtPoint nfp pos refs + nonFOIRefs <- forM names $ \name -> + case nameModule_maybe name of + Nothing -> pure [] + Just mod -> do + -- Look for references (strictly in project files, not dependencies), + -- excluding the files in the FOIs (since those are in foiRefs) + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe rowToLoc rows + typeRefs <- forM names $ \name -> + case nameModule_maybe name of + Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do + refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe typeRowToLoc refs + _ -> pure [] + pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs + +rowToLoc :: Res RefRow -> Maybe Location +rowToLoc (row:.info) = flip Location range <$> mfile + where + range = Range start end + start = Position (refSLine row - 1) (refSCol row -1) + end = Position (refELine row - 1) (refECol row -1) + mfile = case modInfoSrcFile info of + Just f -> Just $ toUri f + Nothing -> Nothing + +typeRowToLoc :: Res TypeRef -> Maybe Location +typeRowToLoc (row:.info) = do + file <- modInfoSrcFile info + pure $ Location (toUri file) range + where + range = Range start end + start = Position (typeRefSLine row - 1) (typeRefSCol row -1) + end = Position (typeRefELine row - 1) (typeRefECol row -1) documentHighlight :: Monad m - => HieASTs Type - -> RefMap + => HieASTs a + -> RefMap a -> Position -> MaybeT m [DocumentHighlight] -documentHighlight hf rf pos = MaybeT $ pure (Just highlights) +documentHighlight hf rf pos = pure highlights where ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) highlights = do @@ -67,38 +169,39 @@ documentHighlight hf rf pos = MaybeT $ pure (Just highlights) gotoTypeDefinition :: MonadIO m - => (Module -> MaybeT m (HieFile, FilePath)) + => HieDb + -> LookupModule m -> IdeOptions - -> HieASTs Type + -> HieAstResult -> Position -> MaybeT m [Location] -gotoTypeDefinition getHieFile ideOpts srcSpans pos - = lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans +gotoTypeDefinition hiedb lookupModule ideOpts srcSpans pos + = lift $ typeLocationsAtPoint hiedb lookupModule ideOpts pos srcSpans -- | Locate the definition of the name at a given position. gotoDefinition :: MonadIO m - => (Module -> MaybeT m (HieFile, FilePath)) + => HieDb + -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs Type + -> HieASTs a -> Position - -> MaybeT m Location -gotoDefinition getHieFile ideOpts imports srcSpans pos - = MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts imports pos srcSpans + -> MaybeT m [Location] +gotoDefinition hiedb getHieFile ideOpts imports srcSpans pos + = lift $ locationsAtPoint hiedb getHieFile ideOpts imports pos srcSpans -- | Synopsis for the name at a given position. atPoint :: IdeOptions - -> HieASTs Type + -> HieAstResult -> DocAndKindMap -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data - hoverInfo ast = - (Just range, prettyNames ++ pTypes) + hoverInfo ast = (Just range, prettyNames ++ pTypes) where pTypes | length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes @@ -114,15 +217,17 @@ atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos ho prettyNames :: [T.Text] prettyNames = map prettyName names prettyName (Right n, dets) = T.unlines $ - wrapHaskell (showNameWithoutUniques n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> maybeKind)) + wrapHaskell (showNameWithoutUniques n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : definedAt n ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] - where maybeKind = safeTyThingType =<< lookupNameEnv km n - prettyName (Left m,_) = showName m + ] + where maybeKind = fmap showGhc $ safeTyThingType =<< lookupNameEnv km n + prettyName (Left m,_) = showGhc m prettyTypes = map (("_ :: "<>) . prettyType) types - prettyType t = showName t + prettyType t = case kind of + HieFresh -> showGhc t + HieFromDisk full_file -> showGhc $ hieTypeToIface $ recoverFullType t (hie_types full_file) definedAt name = -- do not show "at " and similar messages @@ -134,61 +239,118 @@ atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos ho typeLocationsAtPoint :: forall m . MonadIO m - => (Module -> MaybeT m (HieFile, FilePath)) + => HieDb + -> LookupModule m -> IdeOptions -> Position - -> HieASTs Type + -> HieAstResult -> m [Location] -typeLocationsAtPoint getHieFile _ideOptions pos ast = - let ts = concat $ pointCommand ast pos (nodeType . nodeInfo) - ns = flip mapMaybe ts $ \case - TyConApp tc _ -> Just $ tyConName tc - TyVarTy n -> Just $ Var.varName n - _ -> Nothing - in mapMaybeM (nameToLocation getHieFile) ns +typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = + case hieKind of + HieFromDisk hf -> + let arr = hie_types hf + ts = concat $ pointCommand ast pos getts + unfold = map (arr A.!) + getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + where ni = nodeInfo x + getTypes ts = flip concatMap (unfold ts) $ \case + HTyVarTy n -> [n] +#if MIN_GHC_API_VERSION(8,8,0) + HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) +#else + HAppTy a b -> getTypes [a,b] +#endif + HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) + HForAllTy _ a -> getTypes [a] + HFunTy a b -> getTypes [a,b] + HQualTy a b -> getTypes [a,b] + HCastTy a -> getTypes [a] + _ -> [] + in fmap nubOrd $ concatMapM (fmap (maybe [] id) . nameToLocation hiedb lookupModule) (getTypes ts) + HieFresh -> + let ts = concat $ pointCommand ast pos getts + getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + where ni = nodeInfo x + in fmap nubOrd $ concatMapM (fmap (maybe [] id) . nameToLocation hiedb lookupModule) (getTypes ts) + +namesInType :: Type -> [Name] +namesInType (TyVarTy n) = [Var.varName n] +namesInType (AppTy a b) = getTypes [a,b] +namesInType (TyConApp tc ts) = tyConName tc : getTypes ts +namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t +namesInType (FunTy a b) = getTypes [a,b] +namesInType (CastTy t _) = namesInType t +namesInType (LitTy _) = [] +namesInType _ = [] + +getTypes :: [Type] -> [Name] +getTypes ts = concatMap namesInType ts locationsAtPoint - :: forall m + :: forall m a . MonadIO m - => (Module -> MaybeT m (HieFile, FilePath)) + => HieDb + -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position - -> HieASTs Type + -> HieASTs a -> m [Location] -locationsAtPoint getHieFile _ideOptions imports pos ast = +locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in mapMaybeM (either (pure . modToLocation) $ nameToLocation getHieFile) ns + modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns -- | Given a 'Name' attempt to find the location where it is defined. -nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location) -nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $ +nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) +nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of - sp@(RealSrcSpan _) -> pure $ Just sp - sp@(UnhelpfulSpan _) -> runMaybeT $ do + sp@(RealSrcSpan rsp) + -- Lookup in the db if we got a location in a boot file + | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp + sp -> do guard (sp /= wiredInSrcSpan) -- This case usually arises when the definition is in an external package. -- In this case the interface files contain garbage source spans -- so we instead read the .hie files to get useful source spans. mod <- MaybeT $ return $ nameModule_maybe name - (hieFile, srcPath) <- getHieFile mod - avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile - -- The location will point to the source file used during compilation. - -- This file might no longer exists and even if it does the path will be relative - -- to the compilation directory which we don’t know. - let span = setFileName srcPath $ fst avail - pure span + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) + case erow of + [] -> MaybeT $ pure Nothing + xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs + +defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location +defRowToLocation lookupModule (row:.info) = do + let start = Position (defSLine row - 1) (defSCol row - 1) + end = Position (defELine row - 1) (defECol row - 1) + range = Range start end + file <- case modInfoSrcFile info of + Just src -> pure $ toUri src + Nothing -> lookupModule (defSrc row) (modInfoName info) (modInfoUnit info) (modInfoIsBoot info) + pure $ Location file range + +toUri :: FilePath -> Uri +toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' + +defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation +defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) + = Just $ SymbolInformation (showGhc defNameOcc) kind Nothing loc Nothing where - -- We ignore uniques and source spans and only compare the name and the module. - eqName :: Name -> Name -> Bool - eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n' - setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f }) - setFileName _ span@(UnhelpfulSpan _) = span + kind + | isVarOcc defNameOcc = SkVariable + | isDataOcc defNameOcc = SkConstructor + | isTcOcc defNameOcc = SkStruct + | otherwise = SkUnknown 1 + loc = Location file range + file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile + range = Range start end + start = Position (defSLine - 1) (defSCol - 1) + end = Position (defELine - 1) (defECol - 1) +defRowToSymbolInfo _ = Nothing -pointCommand :: HieASTs Type -> Position -> (HieAST Type -> a) -> [a] +pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> case selectSmallestContaining (sp fs) ast of @@ -199,5 +361,3 @@ pointCommand hf pos k = sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos cha = _character pos - - diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 1f47ed8b4c..e7ad090e5e 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -5,7 +5,6 @@ module Development.IDE.Spans.Common ( showGhc -, showName , showNameWithoutUniques , safeTyThingId , safeTyThingType @@ -30,23 +29,21 @@ import ConLike import DataCon import Var import NameEnv +import DynFlags import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H -import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Util type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing -showGhc :: Outputable a => a -> String -showGhc = showPpr unsafeGlobalDynFlags +showGhc :: Outputable a => a -> T.Text +showGhc = showSD . ppr -showName :: Outputable a => a -> T.Text -showName = T.pack . prettyprint - where - prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style - style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay +showSD :: SDoc -> T.Text +showSD = T.pack . unsafePrintSDoc showNameWithoutUniques :: Outputable a => a -> T.Text showNameWithoutUniques = T.pack . prettyprint diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 126e39d797..540ebea44c 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -44,7 +44,7 @@ import HscTypes (HscEnv(hsc_dflags)) mkDocMap :: HscEnv -> [ParsedModule] - -> RefMap + -> RefMap a -> TcGblEnv -> IO DocAndKindMap mkDocMap env sources rm this_mod = @@ -99,8 +99,8 @@ getDocumentationsTryGhc env mod sources names = do src <- toFileUriText $ lookupSrcHtmlForModule df mod return (doc, src) Nothing -> pure (Nothing, Nothing) - let docUri = (<> "#" <> selector <> showName name) <$> docFu - srcUri = (<> "#" <> showName name) <$> srcFu + let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu + srcUri = (<> "#" <> showNameWithoutUniques name) <$> srcFu selector | isValName name = "v:" | otherwise = "t:" diff --git a/ghcide/src/Development/IDE/Spans/LocalBindings.hs b/ghcide/src/Development/IDE/Spans/LocalBindings.hs index 67ed131556..4856523148 100644 --- a/ghcide/src/Development/IDE/Spans/LocalBindings.hs +++ b/ghcide/src/Development/IDE/Spans/LocalBindings.hs @@ -31,14 +31,14 @@ realSrcSpanToInterval rss = (realSrcLocToPosition $ realSrcSpanStart rss) (realSrcLocToPosition $ realSrcSpanEnd rss) -bindings :: RefMap -> Bindings +bindings :: RefMap Type -> Bindings bindings = uncurry Bindings . localBindings ------------------------------------------------------------------------------ -- | Compute which identifiers are in scope at every point in the AST. Use -- 'getLocalScope' to find the results. localBindings - :: RefMap + :: RefMap Type -> ( IntervalMap Position (NameEnv (Name, Maybe Type)) , IntervalMap Position (NameEnv (Name, Maybe Type)) ) diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 7926c04f7e..d1244847cf 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -29,11 +29,12 @@ import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) import Development.Shake.Classes import GHC.Generics import Language.Haskell.LSP.Types +import Development.IDE.Core.PositionMapping data Value v = Succeeded TextDocumentVersion v - | Stale TextDocumentVersion v - | Failed + | Stale (Maybe PositionDelta) TextDocumentVersion v + | Failed Bool -- True if we already tried the persistent rule deriving (Functor, Generic, Show) instance NFData v => NFData (Value v) @@ -42,8 +43,8 @@ instance NFData v => NFData (Value v) -- up2date results not for stale values. currentValue :: Value v -> Maybe v currentValue (Succeeded _ v) = Just v -currentValue (Stale _ _) = Nothing -currentValue Failed = Nothing +currentValue (Stale _ _ _) = Nothing +currentValue Failed{} = Nothing data ValueWithDiagnostics = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) diff --git a/ghcide/test/data/references/Main.hs b/ghcide/test/data/references/Main.hs new file mode 100644 index 0000000000..4a976f3fd0 --- /dev/null +++ b/ghcide/test/data/references/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import References + +main :: IO () +main = return () + + + +a = 2 :: Int +b = a + 1 + +acc :: Account +acc = Savings diff --git a/ghcide/test/data/references/OtherModule.hs b/ghcide/test/data/references/OtherModule.hs new file mode 100644 index 0000000000..4840f46d8e --- /dev/null +++ b/ghcide/test/data/references/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/ghcide/test/data/references/OtherOtherModule.hs b/ghcide/test/data/references/OtherOtherModule.hs new file mode 100644 index 0000000000..d567b8cb97 --- /dev/null +++ b/ghcide/test/data/references/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/ghcide/test/data/references/References.hs b/ghcide/test/data/references/References.hs new file mode 100644 index 0000000000..ac76b4de40 --- /dev/null +++ b/ghcide/test/data/references/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/ghcide/test/data/references/hie.yaml b/ghcide/test/data/references/hie.yaml new file mode 100644 index 0000000000..db42bad0c0 --- /dev/null +++ b/ghcide/test/data/references/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d124a5e77f..bf912b686c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -15,7 +15,8 @@ import Control.Exception (bracket_, catch) import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (FromJSON, Value, toJSON) +import Data.Aeson (FromJSON, Value, toJSON,fromJSON) +import qualified Data.Aeson as A import qualified Data.Binary as Binary import Data.Default import Data.Foldable @@ -23,6 +24,7 @@ import Data.List.Extra import Data.Maybe import Data.Rope.UTF16 (Rope) import qualified Data.Rope.UTF16 as Rope +import qualified Data.Set as Set import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent, PositionResult(..), positionResultToMaybe) import Development.IDE.Core.Shake (Q(..)) import Development.IDE.GHC.Util @@ -66,6 +68,7 @@ import Control.Monad.Extra (whenJust) import qualified Language.Haskell.LSP.Types.Lens as L import Control.Lens ((^.)) import Data.Functor +import Data.Tuple.Extra main :: IO () main = do @@ -105,6 +108,7 @@ main = do , asyncTests , clientSettingsTest , codeActionHelperFunctionTests + , referenceTests ] initializeResponseTests :: TestTree @@ -127,10 +131,10 @@ initializeResponseTests = withResource acquire release tests where -- BUG in lsp-test, this test fails, just change the accepted response -- for now , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True) - , chk "NO find references" _referencesProvider Nothing + , chk " find references" _referencesProvider (Just True) , chk " doc highlight" _documentHighlightProvider (Just True) , chk " doc symbol" _documentSymbolProvider (Just True) - , chk "NO workspace symbol" _workspaceSymbolProvider Nothing + , chk " workspace symbol" _workspaceSymbolProvider (Just True) , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing , chk "NO doc formatting" _documentFormattingProvider Nothing @@ -2908,7 +2912,7 @@ findDefinitionAndHoverTests = let , testGroup "type-definition" typeDefinitionTests ] typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) opL16 (pure [ExpectNoDefinitions]) "Polymorphic variable"] + , tst (getTypeDefinitions, checkDefs) aL20 (pure [ExpectNoDefinitions]) "Polymorphic variable"] test runDef runHover look expect = testM runDef runHover look (return expect) @@ -2922,6 +2926,7 @@ findDefinitionAndHoverTests = let fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] fffL8 = Position 12 4 ; fffL14 = Position 18 7 ; + aL20 = Position 19 15 aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] dcL12 = Position 16 11 ; @@ -4333,6 +4338,178 @@ clientSettingsTest = testGroup "client settings handling" isMessagePresent expectedMsg actualMsgs = liftIO $ assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) + +referenceTests :: TestTree +referenceTests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session [Location] +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ satisfyMaybe $ \case + NotCustomServer (NotificationMessage _ (CustomServerMethod "ghcide/reference/ready") fp) -> do + A.Success fp' <- pure $ fromJSON fp + find (fp' ==) docs + _ -> Nothing + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, Int, Int) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line + , location ^. L.range . L.start . L.character)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' + ---------------------------------------------------------------------- -- Utils ---------------------------------------------------------------------- diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index da977b3aa0..f6e9b81fca 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -57,18 +57,26 @@ library autogen-modules: Paths_haskell_language_server hs-source-dirs: src build-depends: + , async + , base16-bytestring + , bytestring , containers + , cryptohash-sha1 , data-default , ghc , ghcide >=0.7 , gitrev , haskell-lsp ^>=0.23 , hls-plugin-api >=0.6 + , hie-bios + , hiedb , hslogger , optparse-applicative , optparse-simple , process , shake + , safe-exceptions + , sqlite-simple , unordered-containers ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing @@ -303,9 +311,12 @@ executable haskell-language-server build-depends: , aeson + , async + , base16-bytestring , binary , bytestring , containers + , cryptohash-sha1 , deepseq , ghc , ghc-boot-th @@ -313,6 +324,8 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.23 + , hie-bios + , hiedb , lens , regex-tdfa , hslogger @@ -323,6 +336,7 @@ executable haskell-language-server , regex-tdfa , safe-exceptions , shake >=0.17.5 + , sqlite-simple , temporary , transformers , unordered-containers @@ -379,7 +393,7 @@ common hls-test-utils , hspec , hspec-core , lens - , lsp-test >=0.11.0.6 + , lsp-test >=0.12.0.0 , stm , tasty-expected-failure , tasty-hunit diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index d4915387eb..327f12d389 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -166,13 +166,15 @@ codeAction _ state plId docId _ context = fmap (fromMaybe errorResult) . runMayb . Just findClassIdentifier docPath range = do - (hieAst -> hf, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath - pure - $ head . head - $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) - ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) - <=< nodeChildren - ) + (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath + case hieAstResult of + HAR {hieAst = hf} -> + pure + $ head . head + $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1) + ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo) + <=< nodeChildren + ) findClassFromIdentifier docPath (Right name) = do (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index bbb0f3afd2..494865d6ac 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} @@ -248,36 +249,41 @@ judgementForHole state nfp range = do ((modsum,_), _) <- MaybeT $ runIde state $ useWithStale GetModSummaryWithoutTimestamps nfp let dflags = ms_hspp_opts modsum - (rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts $ hieAst asts) $ \fs ast -> - case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of - Nothing -> Nothing - Just ast' -> do - let info = nodeInfo ast' - ty <- listToMaybe $ nodeType info - guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info - pure (nodeSpan ast', ty) - - resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss - (tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp - let tcg = tmrTypechecked tcmod - tcs = tcg_binds tcg - ctx = mkContext - (mapMaybe (sequenceA . (occName *** coerce)) - $ getDefiningBindings binds rss) - tcg - top_provs = getRhsPosVals rss tcs - local_hy = spliceProvenance top_provs - $ hypothesisFromBindings rss binds - cls_hy = contextMethodHypothesis ctx - pure ( resulting_range - , mkFirstJudgement - (local_hy <> cls_hy) - (isRhsHole rss tcs) - goal - , ctx - , dflags - ) - + case asts of + (HAR _ hf _ _ kind) -> do + (rss, goal) <- liftMaybe $ join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range') ast of + Nothing -> Nothing + Just ast' -> do + let info = nodeInfo ast' + ty <- listToMaybe $ nodeType info + guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info + pure (nodeSpan ast', ty) + + resulting_range <- liftMaybe $ toCurrentRange amapping $ realSrcSpanToRange rss + (tcmod, _) <- MaybeT $ runIde state $ useWithStale TypeCheck nfp + let tcg = tmrTypechecked tcmod + tcs = tcg_binds tcg + ctx = mkContext + (mapMaybe (sequenceA . (occName *** coerce)) + $ getDefiningBindings binds rss) + tcg + top_provs = getRhsPosVals rss tcs + local_hy = spliceProvenance top_provs + $ hypothesisFromBindings rss binds + cls_hy = contextMethodHypothesis ctx + case kind of + HieFromDisk hf' -> + fail "Need a fresh hie file" + HieFresh -> + pure ( resulting_range + , mkFirstJudgement + (local_hy <> cls_hy) + (isRhsHole rss tcs) + goal + , ctx + , dflags + ) spliceProvenance :: Map OccName Provenance diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index eaf2e95e44..cd0b5eff05 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -21,14 +21,15 @@ import Development.GitRev import Options.Applicative import Paths_haskell_language_server import System.Environment +import HieDb.Run -- --------------------------------------------------------------------- data Arguments = VersionMode PrintVersion | ProbeToolsMode + | DbCmd Options Command | LspMode LspArguments - deriving Show data LspArguments = LspArguments {argLSP :: Bool @@ -53,9 +54,11 @@ data PrintVersion getArguments :: String -> IO Arguments getArguments exeName = execParser opts where + hieInfo = fullDesc <> progDesc "Query .hie files" opts = info (( VersionMode <$> printVersionParser exeName <|> probeToolsParser exeName + <|> hsubparser (command "hiedb" (info (DbCmd <$> optParser "" True <*> cmdParser <**> helper) hieInfo)) <|> LspMode <$> arguments) <**> helper) ( fullDesc diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index e3310bf2c5..e83cd25a78 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -8,11 +8,13 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} module Ide.Main(defaultMain, runLspMode) where import Control.Concurrent.Extra import Control.Monad.Extra +import Control.Exception.Safe import Data.Default import Data.List.Extra import qualified Data.Map.Strict as Map @@ -31,7 +33,7 @@ import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.Plugin import Development.IDE.Plugin.HLS -import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions) +import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, setInitialDynFlags, getHieDbLoc, runWithDb) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger as G @@ -52,6 +54,7 @@ import System.IO import qualified System.Log.Logger as L import System.Time.Extra import Development.Shake (ShakeOptions (shakeThreads), action) +import HieDb.Run ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) @@ -75,6 +78,16 @@ defaultMain args idePlugins = do VersionMode PrintNumericVersion -> putStrLn haskellLanguageServerNumericVersion + DbCmd opts cmd -> do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc + mlibdir <- setInitialDynFlags + case mlibdir of + Nothing -> exitWith $ ExitFailure 1 + Just libdir -> + runCommand libdir opts{database = dbLoc} cmd + LspMode lspArgs -> do {- see WARNING above -} hPutStrLn stderr hlsVer @@ -94,7 +107,14 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- runLspMode :: LspArguments -> IdePlugins IdeState -> IO () -runLspMode lspArgs@LspArguments{..} idePlugins = do +runLspMode lspArgs@LspArguments{argsCwd} idePlugins = do + whenJust argsCwd IO.setCurrentDirectory + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ runLspMode' lspArgs idePlugins + +runLspMode' :: LspArguments -> IdePlugins IdeState -> HieDb -> IndexQueue -> IO () +runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -103,8 +123,6 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - whenJust argsCwd IO.setCurrentDirectory - dir <- IO.getCurrentDirectory pid <- T.pack . show <$> getProcessID @@ -125,6 +143,9 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps wProg wIndefProg _getConfig _rootPath -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t + + _libdir <- setInitialDynFlags + `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) sessionLoader <- loadSession dir -- config <- fromMaybe defaultLspConfig <$> getConfig let options = defOptions @@ -137,6 +158,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do debouncer <- newAsyncDebouncer initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event wProg wIndefProg hlsLogger debouncer options vfs + hiedb hiechan else do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 @@ -165,7 +187,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do debouncer <- newAsyncDebouncer let dummyWithProg _ _ f = f (const (pure ())) sessionLoader <- loadSession dir - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger Info) debouncer (defaultIdeOptions sessionLoader) vfs hiedb hiechan putStrLn "\nStep 4/4: Type checking the files" setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 1c9dc94069..3127af1b43 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -39,7 +39,7 @@ extra-deps: - HsYAML-aeson-0.2.0.0@rev:2 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -50,6 +50,8 @@ extra-deps: - semigroups-0.18.5 - temporary-1.2.1.1 - uniplate-1.6.13 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 configure-options: ghcide: diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index e721a87553..9fd23383f3 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -35,13 +35,15 @@ extra-deps: - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 configure-options: ghcide: diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 7efe1a0a87..d57488b4f4 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -31,7 +31,7 @@ extra-deps: - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - refinery-0.3.0.0 - retrie-0.1.1.1 @@ -40,6 +40,8 @@ extra-deps: - temporary-1.2.1.1 - haskell-lsp-0.23.0.0 - haskell-lsp-types-0.23.0.0 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 configure-options: ghcide: diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index db0b8a13ff..de32db67e0 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -30,7 +30,6 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - Diff-0.4.0 - - extra-1.7.3 - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 @@ -58,7 +57,7 @@ extra-deps: - implicit-hie-0.1.2.5 - indexed-profunctors-0.1 - lens-4.18 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -82,6 +81,9 @@ extra-deps: - uniplate-1.6.13 - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 flags: haskell-language-server: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 3410f9f787..a34abd3bbd 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -29,7 +29,6 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - Diff-0.4.0 - - extra-1.7.3 - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 @@ -57,7 +56,7 @@ extra-deps: - implicit-hie-0.1.2.5 - indexed-profunctors-0.1 - lens-4.18 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -81,6 +80,9 @@ extra-deps: - uniplate-1.6.13 - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 configure-options: ghcide: diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 5b272d12ff..b6de81ec9e 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -26,7 +26,6 @@ extra-deps: - bytestring-trie-0.2.5.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - - extra-1.7.3 - floskell-0.10.4 - fourmolu-0.3.0.0 - ghc-check-0.5.0.1 @@ -52,7 +51,7 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -66,6 +65,11 @@ extra-deps: - uniplate-1.6.13 - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 + - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 configure-options: ghcide: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 0ab9eca5bc..ed136509ce 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -26,7 +26,6 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - - extra-1.7.3 - floskell-0.10.4 - fourmolu-0.3.0.0 # - ghc-exactprint-0.6.3.3 @@ -47,7 +46,7 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -58,6 +57,11 @@ extra-deps: - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 - uniplate-1.6.13 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 + - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 configure-options: ghcide: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 1575f4d85a..ccc2818031 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -46,7 +46,7 @@ extra-deps: - ilist-0.3.1.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -56,6 +56,10 @@ extra-deps: - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 - uniplate-1.6.13 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 + - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 configure-options: ghcide: diff --git a/stack.yaml b/stack.yaml index 038d83f2a4..2a1c43327b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,7 +31,6 @@ extra-deps: - cabal-plan-0.6.2.0 - clock-0.7.2 - Diff-0.4.0 - - extra-1.7.3 - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 @@ -59,7 +58,7 @@ extra-deps: - implicit-hie-0.1.2.5 - indexed-profunctors-0.1 - lens-4.18 - - lsp-test-0.11.0.6 + - lsp-test-0.12.0.0 - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 @@ -83,6 +82,9 @@ extra-deps: - uniplate-1.6.13 - with-utf8-1.0.2.1@sha256:95c02fffa643ddbeb092359802a512007c3e644cd509809f4716ad54592c437b,3057 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 + - hiedb-0.3.0.1 + - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 configure-options: ghcide: diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs index fce63001ce..14bb24a768 100644 --- a/test/functional/Highlight.hs +++ b/test/functional/Highlight.hs @@ -10,7 +10,7 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "highlight" [ - testCase "works" $ runSession hlsCommand fullCaps "test/testdata" $ do + testCase "works" $ runSession (hlsCommand ++ " --test") fullCaps "test/testdata" $ do doc <- openDoc "Highlight.hs" "haskell" _ <- waitForDiagnosticsFrom doc highlights <- getHighlights doc (Position 2 2) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 1b29e3d6b2..d674e077da 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -93,7 +93,7 @@ expectProgressReports = expectProgressReports' [] CreateM msg -> expectProgressReports' (token msg : tokens) expectedTitles BeginM msg -> do - liftIO $ title msg `expectElem` expectedTitles + liftIO $ title msg `expectElem` ("Indexing references from:":expectedTitles) liftIO $ token msg `expectElem` tokens expectProgressReports' tokens (delete (title msg) expectedTitles) ProgressM msg -> do diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index f94ed27de1..c1b6e7e7b2 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -1,11 +1,9 @@ module TypeDefinition (tests) where -import Control.Lens ((^.)) import Control.Monad.IO.Class +import Data.Tuple.Extra (first3) import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as L -import System.Directory import System.FilePath (()) import Test.Hls.Util import Test.Tasty @@ -14,42 +12,36 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "type definitions" [ testCase "finds local definition of record variable" - $ getTypeDefinitionTest' (11, 23) 8 + $ getTypeDefinitionTest' 10 23 7 0 , testCase "finds local definition of newtype variable" - $ getTypeDefinitionTest' (16, 21) 13 + $ getTypeDefinitionTest' 15 21 12 0 , testCase "finds local definition of sum type variable" - $ getTypeDefinitionTest' (21, 13) 18 + $ getTypeDefinitionTest' 20 13 17 0 , knownBrokenForGhcVersions [GHC88] "Definition of sum type not found from data constructor in GHC 8.8.x" $ testCase "finds local definition of sum type constructor" - $ getTypeDefinitionTest' (24, 7) 18 + $ getTypeDefinitionTest' 23 7 17 0 , testCase "finds non-local definition of type def" - $ getTypeDefinitionTest' (30, 17) 27 + $ getTypeDefinitionTest' 29 19 26 0 , testCase "find local definition of type def" - $ getTypeDefinitionTest' (35, 16) 32 + $ getTypeDefinitionTest' 34 16 31 0 , testCase "find type-definition of type def in component" - $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 + $ getTypeDefinitionTest ("src/Lib2.hs", 12, 20) [("src/Lib.hs", 7, 0)] , testCase "find definition of parameterized data type" - $ getTypeDefinitionTest' (40, 19) 37 + $ getTypeDefinitionTest ("src/Lib.hs", 39, 19) [ ("src/Lib.hs", 36, 0) + , ("src/Lib.hs", 38, 0)] ] -getTypeDefinitionTest :: String -> (Int, Int) -> String -> Int -> Assertion -getTypeDefinitionTest symbolFile symbolPosition definitionFile definitionLine = - failIfSessionTimeout . runSession hlsCommand fullCaps "test/testdata/gototest" $ do - doc <- openDoc symbolFile "haskell" - _ <- openDoc definitionFile "haskell" - defs <- getTypeDefinitions doc $ toPos symbolPosition - fp <- liftIO $ canonicalizePath $ "test/testdata/gototest" definitionFile - liftIO $ do - length defs == 1 @? "Expecting a list containing one location, but got: " ++ show defs - let [def] = defs - def ^. L.uri @?= filePathToUri fp - def ^. L.range . L.start . L.line @?= definitionLine - 1 - def ^. L.range . L.end . L.line @?= definitionLine - 1 +definitionsPath :: FilePath +definitionsPath = "test/testdata/gototest" -getTypeDefinitionTest' :: (Int, Int) -> Int -> Assertion -getTypeDefinitionTest' symbolPosition definitionLine = - getTypeDefinitionTest "src/Lib.hs" symbolPosition "src/Lib.hs" definitionLine +getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion +getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = + failIfSessionTimeout . runSession (hlsCommand ++ " --test") fullCaps definitionsPath $ do + doc <- openDoc symbolFile "haskell" + defs <- getTypeDefinitions doc $ Position symbolLine symbolCol + liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations ---NOTE: copied from Haskell.Ide.Engine.ArtifactMap -toPos :: (Int,Int) -> Position -toPos (l,c) = Position (l-1) (c-1) +getTypeDefinitionTest' :: Int -> Int -> Int -> Int -> Assertion +getTypeDefinitionTest' symbolLine symbolCol definitionLine definitionCol = + getTypeDefinitionTest ("src/Lib.hs", symbolLine, symbolCol) + [("src/Lib.hs", definitionLine, definitionCol)] diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index b5e1189b09..066cddae98 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -6,6 +6,7 @@ module Test.Hls.Util , expectCodeAction , expectDiagnostic , expectNoMoreDiagnostics + , expectSameLocations , failIfSessionTimeout , flushStackEnvironment , fromAction @@ -22,6 +23,7 @@ module Test.Hls.Util , knownBrokenForGhcVersions , logFilePath , setupBuildToolFiles + , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -38,6 +40,7 @@ import Data.Default import Data.List (intercalate) import Data.List.Extra (find) import Data.Maybe +import qualified Data.Set as Set import qualified Data.Text as T import Language.Haskell.LSP.Core import Language.Haskell.LSP.Messages (FromServerMessage(NotLogMessage)) @@ -55,7 +58,7 @@ import Test.Hspec.Runner import Test.Hspec.Core.Formatters hiding (Seconds) import Test.Tasty (TestTree) import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFailBecause) -import Test.Tasty.HUnit (assertFailure) +import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) @@ -397,3 +400,20 @@ failIfSessionTimeout action = action `catch` errorHandler where errorHandler :: Test.SessionException -> IO a errorHandler e@(Test.Timeout _) = assertFailure $ show e errorHandler e = throwIO e + +-- | To locate a symbol, we provide a path to the file from the HLS root +-- directory, the line number, and the column number. (0 indexed.) +type SymbolLocation = (FilePath, Int, Int) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +actual `expectSameLocations` expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line + , location ^. L.range . L.start . L.character)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected'