From 14b206b6a2d4a59f146142836a37acc4b4d236d8 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Tue, 5 May 2020 00:33:34 +0530 Subject: [PATCH 01/10] References Use db for findDef save source file location to db Find source for boot files Use DynFlags from HieDb instead of unsafeGlobalDynFlags Return multiple definitions don't typecheck files on load Add support for persistent stale values Add persistent hie file rule docs wip better typedef defs for deps update hiedb Fix for files with errors Fix build integrate hiedb commands and set dynflags on boot workspace symbol tweaks, cabal.project Write ifaces on save use real mtime for saved files safe indexing bump hiedb Proper refs for FOIs hlint Update exe/Main.hs Co-authored-by: Pepe Iborra Review comments update hiedb Update src/Development/IDE/Core/Shake.hs Co-authored-by: Pepe Iborra Update src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra Update src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra Update src/Development/IDE/Spans/AtPoint.hs Co-authored-by: Pepe Iborra Update src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra Apply suggestions from code review Co-authored-by: Pepe Iborra more careful re-indexing update for hiedb-0.1.0.0 Remove cached-deps stuff for now explicit showSDoc docs in AtPoint add doc comment about database consistency add TODO for better position mapping from diff --- cabal.project | 2 +- ghcide/exe/Arguments.hs | 21 +- ghcide/exe/Main.hs | 96 ++++++- ghcide/ghcide.cabal | 14 +- .../session-loader/Development/IDE/Session.hs | 1 + ghcide/src/Development/IDE/Core/Compile.hs | 36 ++- ghcide/src/Development/IDE/Core/FileExists.hs | 1 + ghcide/src/Development/IDE/Core/OfInterest.hs | 2 +- ghcide/src/Development/IDE/Core/RuleTypes.hs | 21 +- ghcide/src/Development/IDE/Core/Rules.hs | 257 ++++++++++------- ghcide/src/Development/IDE/Core/Service.hs | 7 +- ghcide/src/Development/IDE/Core/Shake.hs | 127 ++++++--- ghcide/src/Development/IDE/GHC/Compat.hs | 2 +- ghcide/src/Development/IDE/GHC/Error.hs | 5 + ghcide/src/Development/IDE/GHC/Util.hs | 12 +- .../IDE/Import/DependencyInformation.hs | 2 +- .../src/Development/IDE/Import/FindImports.hs | 1 + .../Development/IDE/LSP/HoverDefinition.hs | 27 +- .../src/Development/IDE/LSP/LanguageServer.hs | 2 +- .../IDE/Plugin/Completions/Logic.hs | 26 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 258 ++++++++++++++---- ghcide/src/Development/IDE/Spans/Common.hs | 16 +- .../Development/IDE/Spans/Documentation.hs | 6 +- .../Development/IDE/Spans/LocalBindings.hs | 4 +- ghcide/src/Development/IDE/Types/Shake.hs | 4 +- 25 files changed, 694 insertions(+), 256 deletions(-) diff --git a/cabal.project b/cabal.project index 197b2f3c4a..5f4f77d036 100644 --- a/cabal.project +++ b/cabal.project @@ -22,7 +22,7 @@ package ghcide write-ghc-environment-files: never -index-state: 2020-12-13T11:31:58Z +index-state: 2020-12-29T11:31:58Z allow-newer: active:base, diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 11b4320d82..21404fe0bf 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 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") <*> 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 <$> 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 server" + 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 59dca21bb4..2c54d051f7 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -2,6 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" module Main(main) where @@ -31,7 +33,7 @@ import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Test as Test -import Development.IDE.Session (loadSession) +import Development.IDE.Session (loadSession, cacheDir) import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -55,6 +57,23 @@ import Text.Printf import Development.IDE.Core.Tracing import Development.IDE.Types.Shake (Key(Key)) +import HieDb.Create +import HieDb.Types +import HieDb.Utils +import Database.SQLite.Simple +import qualified Data.ByteString.Char8 as B +import qualified Crypto.Hash.SHA1 as H +import Control.Concurrent.Async +import Control.Exception +import System.Directory +import Data.ByteString.Base16 +import HieDb.Run (Options(..), runCommand) +import Maybes (MaybeT(runMaybeT)) +import HIE.Bios.Types (CradleLoadResult(..)) +import HIE.Bios.Environment (getRuntimeGhcLibDir) +import DynFlags + + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -66,6 +85,31 @@ ghcideVersion = do <> ") (PATH: " <> path <> ")" <> gitHashSection +-- | 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 -> HieWriterChan -> IO ()) -> IO () +runWithDb fp k = + withHieDb fp $ \writedb -> do + execute_ (getConn writedb) "PRAGMA journal_mode=WAL;" + initConn writedb + chan <- newChan + race_ (writerThread writedb chan) (withHieDb fp (flip k chan)) + where + writerThread db chan = forever $ do + k <- readChan chan + k db `catch` \e@SQLError{} -> do + hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e + +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb" + dirHash = B.unpack $ encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) + main :: IO () main = do -- WARNING: If you write to stdout before runLanguageServer @@ -75,15 +119,47 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + whenJust argsCwd IO.setCurrentDirectory + + -- We want to set the global DynFlags right now, so that we can use + -- `unsafeGlobalDynFlags` even before the project is configured + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + hieYaml <- runMaybeT $ yamlConfig dir + cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + libDirRes <- getRuntimeGhcLibDir cradle + libdir <- case libDirRes of + CradleSuccess libdir -> pure $ Just libdir + CradleFail err -> do + hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show err + return Nothing + CradleNone -> return Nothing + dynFlags <- mapM (dynFlagsForPrinting . LibDir) libdir + mapM_ setUnsafeGlobalDynFlags dynFlags + + case argFilesOrCmd of + DbCmd cmd -> do + let opts :: Options + opts = Options + { database = dbLoc + , trace = False + , quiet = False + , virtualFile = False + } + runCommand (LibDir $ fromJust libdir) opts cmd + Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde dir Arguments{..} + _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde dir Arguments{..} + + +runIde :: FilePath -> Arguments' (Maybe [FilePath]) -> HieDb -> HieWriterChan -> IO () +runIde dir Arguments{..} hiedb hiechan = do + command <- makeLspCommandId "typesignature.add" + -- 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 - command <- makeLspCommandId "typesignature.add" let plugins = Completions.plugin <> CodeAction.plugin <> if argsTesting then Test.plugin else mempty @@ -97,8 +173,8 @@ main = do options = def { LSP.executeCommandCommands = Just [command] , 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!" @@ -127,8 +203,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 @@ -162,7 +238,7 @@ main = do , optCheckProject = CheckProject False } 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 diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index b0d99e7188..03b2508844 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -56,6 +56,7 @@ library haskell-lsp-types == 0.22.*, haskell-lsp == 0.22.*, hie-compat, + hiedb, mtl, network-uri, parallel, @@ -239,6 +240,8 @@ executable ghcide if flag(ghc-lib) buildable: False default-language: Haskell2010 + include-dirs: + include hs-source-dirs: exe ghc-options: -threaded @@ -253,6 +256,13 @@ executable ghcide "-with-rtsopts=-I0 -qg -A128M" main-is: Main.hs build-depends: + time, + async, + bytestring, + base16-bytestring, + cryptohash-sha1, + hslogger, + hiedb, aeson, base == 4.*, data-default, @@ -260,6 +270,7 @@ executable ghcide extra, filepath, gitrev, + ghc, hashable, haskell-lsp, haskell-lsp-types, @@ -269,7 +280,8 @@ executable ghcide lens, optparse-applicative, text, - unordered-containers + unordered-containers, + sqlite-simple other-modules: Arguments Paths_ghcide diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6b26610063..cb81af7abb 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -8,6 +8,7 @@ module Development.IDE.Session ,defaultLoadingOptions ,loadSession ,loadSessionWithOptions + ,cacheDir ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 86401c2c9f..d6c9b06951 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,16 @@ 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 +import Control.Concurrent.Chan + +import HieDb import Language.Haskell.LSP.Types (DiagnosticTag(..)) @@ -95,6 +101,9 @@ import PrelNames import HeaderInfo import Maybes (orElse) +import Control.Concurrent.Extra (modifyVar_,modifyVar) +import qualified Data.HashSet as HashSet + -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions @@ -390,12 +399,29 @@ generateHieAsts hscEnv tcm = where dflags = hsc_dflags hscEnv -writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] -writeHieFile hscEnv mod_summary exports ast source = +indexHieFile :: HieDbWriter -> ModSummary -> NormalizedFilePath -> Compat.HieFile -> IO () +indexHieFile dbwriter mod_summary srcPath hf = do + index <- modifyVar (pendingIndexes dbwriter) $ \pending -> pure $ + if HashSet.member srcPath pending + then (pending,False) + else (HashSet.insert srcPath pending, True) + when index $ writeChan (channel dbwriter) $ \db -> do + hPutStrLn stderr $ "Started indexing .hie file: " ++ targetPath ++ " for: " ++ show srcPath + addRefsFromLoaded db targetPath (Just $ fromNormalizedFilePath srcPath) True modtime hf + modifyVar_ (pendingIndexes dbwriter) (pure . HashSet.delete srcPath) + hPutStrLn stderr $ "Finished indexing .hie file: " ++ targetPath + where + modtime = ms_hs_date mod_summary + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + +writeAndIndexHieFile :: HscEnv -> HieDbWriter -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] +writeAndIndexHieFile hscEnv hiechan 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 + indexHieFile hiechan mod_summary srcPath hf where dflags = hsc_dflags hscEnv mod_location = ms_location mod_summary @@ -403,7 +429,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 @@ -736,7 +762,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/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index d3bef5f1c2..c0cb6bd9d0 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/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 86bf2a75c9..d43135924d 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -5,6 +5,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -134,18 +135,28 @@ 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` + , 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 kind) = rnf m `seq` rwhnf hf `seq` rnf kind + instance Show HieAstResult where show = show . hieModule diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 9ad5a705cf..1986034b96 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -25,13 +25,14 @@ module Development.IDE.Core.Rules( getDefinition, getTypeDefinition, highlightAtPoint, + refsAtPoint, + workspaceSymbols, getDependencies, getParsedModule, ) where import Fingerprint -import Data.Binary hiding (get, put) import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class @@ -65,7 +66,7 @@ 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 qualified GHC.LanguageExtensions as LangExt import HscTypes hiding (TargetModule, TargetFile) @@ -77,12 +78,9 @@ 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.Concurrent.Async (concurrently) -import System.Time.Extra import Control.Monad.Reader -import System.Directory ( getModificationTime ) -import Control.Exception +import Control.Exception.Safe import Control.Monad.State import FastString (FastString(uniq)) @@ -96,6 +94,8 @@ import Data.IORef import Control.Concurrent.Extra import Module +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 -- warnings while also producing a result. @@ -118,7 +118,7 @@ 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" @@ -127,6 +127,17 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ \k file -> do ------------------------------------------------------------ -- 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 + :: HieWriterChan -- ^ 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]) @@ -134,81 +145,62 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file -- | 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 + hiedbChan <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod $ channel hiedbChan) 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 + hiedbChan <- lift $ asks hiedbWriter + toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod $ channel hiedbChan) 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' + +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 getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do @@ -217,28 +209,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 daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) getParsedModule file = use GetParsedModule file @@ -319,7 +289,7 @@ mergeParseErrorsHaddock normal haddock = normal ++ fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x | otherwise = "Haddock: " <> x -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 @@ -526,17 +496,20 @@ getHieAstsRule = 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 [] _ | 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 (hiedbWriter se) msum f exports asts source _ -> pure [] let refmap = generateReferencesMap . getAsts <$> masts - pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap) + pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> pure HieFresh) getImportMapRule :: Rules() getImportMapRule = define $ \GetImportMap f -> do @@ -547,8 +520,10 @@ getImportMapRule = define $ \GetImportMap f -> do 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 = @@ -557,7 +532,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' @@ -572,7 +547,32 @@ getDocMapRule = dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc return ([],Just dkMap) --- Typechecks a module. +persistentHieFileRule :: Rules () +persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk file + let refmap = generateReferencesMap . getAsts . hie_asts $ res + pure $ HAR (hie_module res) (hie_asts res) refmap (HieFromDisk res) + +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) + readHieFileFromDisk hie_loc + +readHieFileFromDisk :: FilePath -> MaybeT 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 + MaybeT $ pure $ eitherToMaybe res + +-- | Typechecks a module. typeCheckRule :: Rules () typeCheckRule = define $ \TypeCheck file -> do pm <- use_ GetParsedModule file @@ -604,7 +604,6 @@ typeCheckRuleDefinition hsc pm = do IdeOptions { optDefer = defer } <- getIdeOptions linkables_to_keep <- currentLinkables - addUsageDependencies $ liftIO $ typecheckModule defer hsc linkables_to_keep pm where @@ -686,6 +685,17 @@ ghcSessionDepsDefinition file = do res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' [] return ([], Just res) + +-- This function is also 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. Most of the time, there should be an up2date `.hi` file on +-- disk since we are careful to write out the `.hie` file before writing the +-- `.hi` file +-- If we don't have a `.hi` file, the `regenerateHiFile` function is responsible +-- for generating both a fresh `hi` and `hie` file, and queueing up a +-- index operation for the `.hie` file. getModIfaceFromDiskRule :: Rules () getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do (ms,_) <- use_ GetModSummary f @@ -699,7 +709,47 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do case r of (diags, Just x) -> do let fp = Just (hiFileFingerPrint x) - return (fp, (diags <> diags_session, Just x)) + + -- Check state of hiedb - have we indexed the corresponding `.hie` file? + se@ShakeExtras{hiedb,hiedbWriter} <- getShakeExtras + mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) + + case mrow of + -- All good! + Just row | ms_hs_date ms <= HieDb.modInfoTime (HieDb.hieModInfo row) -> + return (fp, (diags <> diags_session, Just x)) + + -- Must re-index + _ -> do + let hie_loc = ml_hie_file $ ms_location ms + mbHieVersion <- use GetModificationTime_{missingFileDiagnostics=False} + $ toNormalizedFilePath' hie_loc + + case mbHieVersion of + -- File is up2date on disk, we can re-index after reading it + Just hieVersion | modificationTime hieVersion > Just (ms_hs_date ms) -> do + + mhf <- liftIO $ runIdeAction "GetModIfaceFromDisk" se $ runMaybeT $ + readHieFileFromDisk hie_loc + case mhf of + + -- Re-index + Just hf -> liftIO $ do + indexHieFile hiedbWriter ms f hf + return (fp, (diags <> diags_session, Just x)) + + -- Uh oh, we failed to read the file, need to regenerate it + Nothing -> do + (diags', res) <- regenerateHiFile session f ms linkableType + let fp = hiFileFingerPrint <$> res + return (fp, (diags' <> diags_session, res)) + + -- Must regenerate and re-index + _ -> do + (diags', res) <- regenerateHiFile session f ms linkableType + let fp = hiFileFingerPrint <$> res + return (fp, (diags' <> diags_session, res)) + (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing)) isHiFileStableRule :: Rules () @@ -855,18 +905,26 @@ regenerateHiFile sess f ms compNeeded = do -- Write hi file hiDiags <- case res of - Just hiFile - | not $ tmrDeferedError tmr -> - liftIO $ writeHiFile hsc hiFile + Just hiFile -> do + + -- Write hie file + -- Do this before writing the .hi file to ensure that we always have a .hie file + -- if we have a .hi file + ShakeExtras{hiedbWriter} <- getShakeExtras + (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr + source <- getSourceFileSource f + wDiags <- forM masts $ \asts -> + liftIO $ writeAndIndexHieFile hsc hiedbWriter (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + + hiDiags <- if not $ tmrDeferedError tmr + then liftIO $ writeHiFile hsc hiFile + else pure [] + + pure (hiDiags <> gDiags <> concat wDiags) _ -> 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) @@ -956,6 +1014,7 @@ mainRule = do needsCompilationRule generateCoreRule getImportMapRule + persistentHieFileRule -- | 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 e43a8658a6..95346f1dba 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -32,6 +32,7 @@ import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Development.IDE.Core.Shake import Control.Monad +import HieDb.Types @@ -49,8 +50,10 @@ initialise :: LSP.ClientCapabilities -> Debouncer LSP.NormalizedUri -> IdeOptions -> VFSHandle + -> HieDb + -> HieWriterChan -> 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 @@ -62,6 +65,8 @@ initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer opti (optShakeProfiling options) (optReportProgress options) (optTesting options) + hiedb + hiedbChan shakeOptions { shakeThreads = optThreads options , shakeFiles = fromMaybe "/dev/null" (optShakeFiles options) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 7d5a9eca5a..b5636f1c3f 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,9 @@ module Development.IDE.Core.Shake( mkUpdater, -- Exposed for testing. Q(..), + HieWriterChan, + HieDbWriter(..), + addPersistentRule ) where import Development.Shake hiding (ShakeValue, doesFileExist, Info) @@ -69,6 +73,7 @@ import Development.Shake.Database import Development.Shake.Classes import Development.Shake.Rule import qualified Data.HashMap.Strict as HMap +import qualified Data.HashSet as HSet import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS import Data.Dynamic @@ -127,6 +132,18 @@ import PrelInfo import Language.Haskell.LSP.Types.Capabilities import OpenTelemetry.Eventlog +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 + { channel :: HieWriterChan + , pendingIndexes :: Var (HSet.HashSet NormalizedFilePath) + } +type HieWriterChan = Chan (HieDb -> IO ()) + -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras {eventer :: LSP.FromServerMessage -> IO () @@ -165,6 +182,11 @@ 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) } type WithProgressFunc = forall a. @@ -176,6 +198,8 @@ data ProgressEvent = KickStarted | KickCompleted +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe Dynamic) + getShakeExtras :: Action ShakeExtras getShakeExtras = do Just x <- getShakeExtra @ShakeExtras @@ -186,6 +210,17 @@ 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)) -> Rules () +addPersistentRule k getVal = do + ShakeExtras{persistentKeys} <- getShakeExtrasRules + liftIO $ modifyVar_ persistentKeys $ \hm -> do + pure $ HMap.insert (Key k) (fmap (fmap toDyn) . getVal) hm + return () + class Typeable a => IsIdeGlobal a where addIdeGlobal :: IsIdeGlobal a => a -> Rules () @@ -232,26 +267,52 @@ 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 + let readPersistent = 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 <- MaybeT $ runIdeAction "lastValueIO" s $ f file + MaybeT $ pure $ fromDynamic dv + modifyVar state $ \hm -> case mv of + Nothing -> pure (HMap.insertWith upd (file,Key k) (Failed True) hm,Nothing) + -- TODO, we can do better than zeroMapping here by leveraging a diff + Just v -> pure (HMap.insertWith upd (file,Key k) (Stale Nothing (toDyn v)) hm, Just (v,zeroMapping)) + + -- Update preserving 'monotonicity' + -- Don't want to overwrite a newer value with an older one + upd _new@(Failed False) old = old + upd new@(Failed True) (Failed False) = new + upd _new@(Failed True) old = old + upd new@(Stale _ _) Failed{} = new + upd new@(Stale v _) old@(Stale v' _) = if v >= v' then new else old + upd new@(Stale v _) old@(Succeeded v' _) = if v >= v' then new else old + upd new _old = new + + hm <- readVar state + allMappings <- readVar positionMapping + case HMap.lookup (file,Key k) hm of + Nothing -> readPersistent + Just v -> case v of + Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) + Stale ver (fromDynamic -> Just v) -> pure (Just (v, 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 + Failed _ -> Nothing mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) @@ -354,7 +415,7 @@ 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 + Failed _ -> b -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: IO LSP.LspId @@ -367,12 +428,13 @@ shakeOpen :: IO LSP.LspId -> Maybe FilePath -> IdeReportProgress -> IdeTesting + -> HieDb + -> Chan (HieDb -> IO ()) -> 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 hiedbChan opts rules = mdo inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -387,7 +449,10 @@ 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 + pendingIndexes <- newVar HSet.empty + let hiedbWriter = HieDbWriter hiedbChan pendingIndexes progressAsync <- async $ when reportProgress $ progressThread mostRecentProgressEvent inProgress @@ -710,10 +775,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) } @@ -740,16 +803,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) @@ -816,8 +879,8 @@ 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) + mapM (lastValue key) files -- | Define a new Rule with early cutoff defineEarlyCutoff @@ -848,11 +911,11 @@ 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) + Failed b -> (toShakeValue ShakeResult bs, Failed b) Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) liftIO $ setValues state key file res updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags @@ -875,7 +938,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 8091bdb9c1..f89703f725 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -151,7 +151,7 @@ upNameCache = updNameCache #endif -type RefMap = Map Identifier [(Span, IdentifierDetails Type)] +type RefMap a = Map Identifier [(Span, IdentifierDetails a)] mkHieFile' :: ModSummary -> [AvailInfo] 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..d9f45daa6e 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, showSDoc, 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 6aa73574f3..48067f4801 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -8,6 +8,8 @@ module Development.IDE.LSP.HoverDefinition , setHandlersDefinition , setHandlersTypeDefinition , setHandlersDocHighlight + , setHandlersReferences + , setHandlersWsSymbols -- * For haskell-language-server , hover , gotoDefinition @@ -29,16 +31,33 @@ 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, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c +setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition + , setHandlersDocHighlight, setHandlersReferences, setHandlersWsSymbols :: PartialHandlers c setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x -> @@ -47,6 +66,10 @@ setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{LSP.hoverHandler = withResponse RspHover $ const hover} 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 9a3c37a166..2c9357ae20 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 <> setHandlersHover <> setHandlersTypeDefinition <> - setHandlersDocHighlight <> + setHandlersDocHighlight <> setHandlersReferences <> setHandlersWsSymbols <> setHandlersOutline <> userHandlers <> setHandlersNotifications <> -- absolutely critical, join them with user notifications diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index e6adbb310a..2647687720 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -187,7 +187,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 @@ -196,7 +196,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) @@ -214,7 +214,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 = [] @@ -260,21 +260,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 (\c -> c /= '_') 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 @@ -416,11 +416,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) @@ -697,7 +697,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) @@ -715,7 +715,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..92addbbaf4 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -1,6 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} + -- | 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,21 +11,24 @@ module Development.IDE.Spans.AtPoint ( , gotoTypeDefinition , documentHighlight , pointCommand + , referencesAtPoint + , 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 @@ -31,6 +36,8 @@ import TyCoRep import TyCon import qualified Var import NameEnv +import IfaceType +import FastString (unpackFS) import Control.Applicative import Control.Monad.Extra @@ -38,20 +45,100 @@ 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.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)) + +-- | 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 _, mapping) xs = refs ++ xs + where + refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) + $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) 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 $ search hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + pure $ mapMaybe rowToLoc rows + -- Type references are expensive to compute, so we only look for them in the database, not the FOIs + -- Some inaccuracy for FOIs can be expected. + typeRefs <- forM names $ \name -> + case nameModule_maybe name of + Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do + refs <- liftIO $ findTypeRefs hiedb (nameOccName name) (moduleName mod) (moduleUnitId mod) + 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 +154,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 +202,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 +224,110 @@ 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] + HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) + 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 + getTypes ts = flip concatMap ts $ \case + TyVarTy n -> [Var.varName n] + AppTy a b -> getTypes [a,b] + TyConApp tc ts -> tyConName tc : getTypes ts + ForAllTy _ t -> getTypes [t] + FunTy _ a b -> getTypes [a,b] + CastTy t _ -> getTypes [t] + _ -> [] + in fmap nubOrd $ concatMapM (fmap (maybe [] id) . nameToLocation hiedb lookupModule) (getTypes 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 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 +-- traceM $ "DEFROW TO LOC ******************" ++ show (range, modInfoSrcFile info) + 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 @@ -200,4 +339,3 @@ pointCommand hf pos k = 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..7a631a0969 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,22 @@ 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 -showName :: Outputable a => a -> T.Text -showName = T.pack . prettyprint - where - prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style - style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay +showGhc :: Outputable a => a -> T.Text +showGhc = showSD . ppr + +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 b6a8327a40..afbc67d6e2 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 <> showGhc name) <$> docFu + srcUri = (<> "#" <> showGhc 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 b2af70c74c..d46d8d924f 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -12,7 +12,7 @@ import Language.Haskell.LSP.Types data Value v = Succeeded TextDocumentVersion v | Stale TextDocumentVersion v - | Failed + | Failed Bool deriving (Functor, Generic, Show) instance NFData v => NFData (Value v) @@ -22,7 +22,7 @@ instance NFData v => NFData (Value v) currentValue :: Value v -> Maybe v currentValue (Succeeded _ v) = Just v currentValue (Stale _ _) = Nothing -currentValue Failed = Nothing +currentValue Failed{} = Nothing -- | The state of the all values. type Values = HashMap (NormalizedFilePath, Key) (Value Dynamic) From f9a4ec7da858d38784a76c0f3129ee45f3df5d54 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Thu, 31 Dec 2020 07:25:45 -0600 Subject: [PATCH 02/10] Make HLS compile with (GHC 8.10.2) and ghcide+hiedb. Hacks to tactics plugic, class plugin, cabal file, and main. --- haskell-language-server.cabal | 17 +++-- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 16 +++-- plugins/tactics/src/Ide/Plugin/Tactic.hs | 68 ++++++++++--------- src/Ide/Main.hs | 44 +++++++++++- stack-8.10.2.yaml | 1 + 5 files changed, 101 insertions(+), 45 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3b5b9153d6..7dbe5c58a6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -56,18 +56,25 @@ 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.6.0.1 , gitrev , haskell-lsp ^>=0.22 + , hie-bios + , hiedb , hls-plugin-api >=0.5 , hslogger , optparse-applicative , optparse-simple , process , shake + , sqlite-simple , unordered-containers ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing @@ -285,9 +292,12 @@ executable haskell-language-server build-depends: , aeson + , async + , base16-bytestring , binary , bytestring , containers + , cryptohash-sha1 , deepseq , ghc , ghc-boot-th @@ -295,6 +305,8 @@ executable haskell-language-server , hashable , haskell-language-server , haskell-lsp ^>=0.22 + , hie-bios + , hiedb , lens , regex-tdfa , hslogger @@ -305,6 +317,7 @@ executable haskell-language-server , regex-tdfa , safe-exceptions , shake >=0.17.5 + , sqlite-simple , temporary , time , transformers @@ -453,7 +466,3 @@ test-suite wrapper-test hs-source-dirs: test/wrapper main-is: Main.hs ghc-options: -Wall - - - - diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 27dc547b0e..624c620b10 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -167,13 +167,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/tactics/src/Ide/Plugin/Tactic.hs b/plugins/tactics/src/Ide/Plugin/Tactic.hs index 41deaa7eb6..da048f4185 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic.hs +++ b/plugins/tactics/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} @@ -250,36 +251,42 @@ 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' -> + -- TODO FIXME XXX. + fail undefined + HieFresh -> + pure ( resulting_range + , mkFirstJudgement + (local_hy <> cls_hy) + (isRhsHole rss tcs) + goal + , ctx + , dflags + ) spliceProvenance :: Map OccName Provenance @@ -365,4 +372,3 @@ getRhsPosVals rss tcs -- TODO(sandy): Make this more robust isHole :: OccName -> Bool isHole = isPrefixOf "_" . occNameString - diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 652ff517c0..cafd894a81 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -34,7 +34,7 @@ import Development.IDE.Core.Shake import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.Plugin -import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions) +import Development.IDE.Session (loadSession, findCradle, defaultLoadingOptions, cacheDir) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger @@ -56,6 +56,16 @@ import qualified System.Log.Logger as L import System.Time.Extra import Development.Shake (action) +import HieDb.Create +import HieDb.Types +import Database.SQLite.Simple +import qualified Data.ByteString.Char8 as B +import qualified Crypto.Hash.SHA1 as H +import Control.Concurrent.Async +import Control.Exception +import System.Directory +import Data.ByteString.Base16 + -- --------------------------------------------------------------------- -- ghcide partialhandlers import Development.IDE.Plugin.CodeAction as CodeAction @@ -91,8 +101,35 @@ defaultMain args idePlugins = do hPutStrLn stderr hlsVer runLspMode lspArgs idePlugins +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = dirHash++"-"++takeBaseName dir++"-"++VERSION_ghc <.> "hiedb" + dirHash = B.unpack $ encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) + runLspMode :: LspArguments -> IdePlugins -> IO () -runLspMode lspArgs@LspArguments{..} idePlugins = do +runLspMode lspArgs idePlugins = do + dir <- IO.getCurrentDirectory + dbLoc <- getHieDbLoc dir + runWithDb dbLoc $ runLspMode' lspArgs idePlugins + +runWithDb :: FilePath -> (HieDb -> HieWriterChan -> IO ()) -> IO () +runWithDb fp k = + withHieDb fp $ \writedb -> do + execute_ (getConn writedb) "PRAGMA journal_mode=WAL;" + initConn writedb + chan <- newChan + race_ (writerThread writedb chan) (withHieDb fp (flip k chan)) + where + writerThread db chan = forever $ do + k <- readChan chan + k db `catch` \e@SQLError{} -> do + hPutStrLn stderr $ "Error in worker, ignoring: " ++ show e + +runLspMode' :: LspArguments -> IdePlugins -> HieDb -> HieWriterChan -> IO () +runLspMode' lspArgs@LspArguments{..} idePlugins hiedb hiechan = do LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -139,6 +176,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 @@ -167,7 +205,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.2.yaml b/stack-8.10.2.yaml index 7e0b778694..012e8a1474 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -23,6 +23,7 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - heapsize-0.3.0 +- hiedb-0.1.0.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 - lsp-test-0.11.0.6 From d441cbe0633b8ae887335915b5edea9776f3ac43 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Thu, 31 Dec 2020 09:02:10 -0600 Subject: [PATCH 03/10] HLS unit tests for the find references functionality. --- test/functional/Reference.hs | 201 ++++++++++++++++-- test/testdata/References.hs | 9 - test/testdata/references/cabal.project | 2 + .../dependencyfoo/dependencyfoo.cabal | 12 ++ .../dependencyfoo/src/ModuleInDependency.hs | 3 + .../src/OtherModuleInDependency.hs | 5 + test/testdata/references/exe/Main.hs | 11 + test/testdata/references/hie.yaml | 10 + test/testdata/references/references.cabal | 18 ++ test/testdata/references/src/OtherModule.hs | 9 + .../references/src/OtherOtherModule.hs | 3 + test/testdata/references/src/References.hs | 25 +++ 12 files changed, 277 insertions(+), 31 deletions(-) delete mode 100644 test/testdata/References.hs create mode 100644 test/testdata/references/cabal.project create mode 100644 test/testdata/references/dependencyfoo/dependencyfoo.cabal create mode 100644 test/testdata/references/dependencyfoo/src/ModuleInDependency.hs create mode 100644 test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs create mode 100644 test/testdata/references/exe/Main.hs create mode 100644 test/testdata/references/hie.yaml create mode 100644 test/testdata/references/references.cabal create mode 100644 test/testdata/references/src/OtherModule.hs create mode 100644 test/testdata/references/src/OtherOtherModule.hs create mode 100644 test/testdata/references/src/References.hs diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index fbe2ce2330..2e3ef040a0 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -2,34 +2,191 @@ module Reference (tests) where import Control.Lens import Control.Monad.IO.Class -import Data.List +import Control.Monad (forM) +import qualified Data.Set as Set import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens +import System.Directory (canonicalizePath) +import System.FilePath (()) +import System.Time.Extra (sleep) import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit tests :: TestTree -tests = testGroup "references" [ - ignoreTestBecause "Broken" $ testCase "works with definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - doc <- openDoc "References.hs" "haskell" - let pos = Position 2 7 -- foo = bar <-- - refs <- getReferences doc pos True - liftIO $ map (Location (doc ^. uri)) [ - mkRange 4 0 4 3 - , mkRange 8 11 8 14 - , mkRange 7 7 7 10 - , mkRange 4 14 4 17 - , mkRange 4 0 4 3 - , mkRange 2 6 2 9 - ] `isInfixOf` refs @? "Contains references" - -- TODO: Respect withDeclaration parameter - -- ignoreTestBecause "Broken" $ testCase "works without definitions" $ runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "References.hs" "haskell" - -- let pos = Position 2 7 -- foo = bar <-- - -- refs <- getReferences doc pos False - -- liftIO $ refs `shouldNotContain` [Location (doc ^. uri) (mkRange 4 0 4 3)] +tests = testGroup "references" + [ testGroup "can get references to a symbol which is local to one module" + [ testCase "can get references to symbols" $ + referenceTest ("src/References.hs", 4, 7) + YesIncludeDeclaration + [ ("src/References.hs", 4, 6) + , ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + + , testCase "can get references to data constructor" $ + referenceTest ("src/References.hs", 13, 2) + YesIncludeDeclaration + [ ("src/References.hs", 13, 2) + , ("src/References.hs", 16, 14) + , ("src/References.hs", 19, 21) + ] + + , testCase "getting references works in the other module" $ + referenceTest ("src/OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("src/OtherModule.hs", 6, 0) + , ("src/OtherModule.hs", 8, 16) + ] + + , testCase "getting references works in the Main module" $ + referenceTest ("exe/Main.hs", 9, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 9, 0) + , ("exe/Main.hs", 10, 4) + ] + + , testCase "getting references to main works" $ + referenceTest ("exe/Main.hs", 5, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 4, 0) + , ("exe/Main.hs", 5, 0) + ] + + , testCase "getting references in the other package" $ + referenceTest ("dependencyfoo/src/OtherModuleInDependency.hs", 2, 0) + YesIncludeDeclaration + [ ("dependencyfoo/src/OtherModuleInDependency.hs", 2, 0) + , ("dependencyfoo/src/OtherModuleInDependency.hs", 4, 13) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + testCase "works when we ask to exclude declarations" $ + referenceTest ("src/References.hs", 4, 7) + NoExcludeDeclaration + [ ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + + , testCase "INCORRECTLY returns declarations when we ask to exclude them" $ + referenceTest ("src/References.hs", 4, 7) + NoExcludeDeclaration + [ ("src/References.hs", 4, 6) + , ("src/References.hs", 6, 0) + , ("src/References.hs", 6, 14) + , ("src/References.hs", 9, 7) + , ("src/References.hs", 10, 11) + ] + ] + + , testGroup "can get references to a symbol which is local to one package" + [ testCase "can get references to symbol defined in a module we import" $ + referenceTest ("src/References.hs", 22, 4) + YesIncludeDeclaration + [ ("src/References.hs", 22, 4) + , ("src/OtherModule.hs", 0, 20) + , ("src/OtherModule.hs", 4, 0) + ] + + , testCase "can get references in modules that import us to symbols we define" $ + referenceTest ("src/OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("src/References.hs", 22, 4) + , ("src/OtherModule.hs", 0, 20) + , ("src/OtherModule.hs", 4, 0) + ] + + , testCase "can get references to symbol defined in a module we import transitively" $ + referenceTest ("src/References.hs", 24, 4) + YesIncludeDeclaration + [ ("src/References.hs", 24, 4) + , ("src/OtherModule.hs", 0, 48) + , ("src/OtherOtherModule.hs", 2, 0) + ] + + , testCase "can get references in modules that import us transitively to symbols we define" $ + referenceTest ("src/OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("src/References.hs", 24, 4) + , ("src/OtherModule.hs", 0, 48) + , ("src/OtherOtherModule.hs", 2, 0) + ] + ] + + , testGroup "can get references to a symbol which is local to one project" + [ testCase "can get references to symbol defined in dependency" $ + referenceTest ("exe/Main.hs", 7, 6) + YesIncludeDeclaration + [ ("exe/Main.hs", 7, 6) + , ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + ] + + , testCase "can get references in our dependents to a symbol we define" $ + referenceTest ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + YesIncludeDeclaration + [ ("exe/Main.hs", 7, 6) + , ("dependencyfoo/src/ModuleInDependency.hs", 2, 0) + ] + ] ] - where mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + +-- | 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) + +-- | 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 + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +actual `expectSameLocations` expected = do + let actual' = + Set.map (\location -> (location ^. uri + , location ^. range . start . line + , location ^. range . start . character)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath $ referencesPath file + return (filePathToUri fp, l, c)) + actual' @?= expected' + +referencesPath :: FilePath +referencesPath = "test/testdata/references" + +referenceTestSession :: Session a -> IO a +referenceTestSession f = runSession hlsCommand fullCaps referencesPath $ do + -- Preload all the files we need. + -- TODO: Something needs to change ... + -- These tests take forever anyway while HLS does stuff with cabal. + _ <- openDoc "exe/Main.hs" "haskell" + _ <- openDoc "src/OtherModule.hs" "haskell" + _ <- openDoc "src/OtherOtherModule.hs" "haskell" + _ <- openDoc "src/References.hs" "haskell" + _ <- openDoc "dependencyfoo/src/ModuleInDependency.hs" "haskell" + _ <- openDoc "dependencyfoo/src/OtherModuleInDependency.hs" "haskell" + liftIO $ sleep 2 + f + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> Assertion +referenceTest loc includeDeclaration expected = + referenceTestSession $ do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` expected diff --git a/test/testdata/References.hs b/test/testdata/References.hs deleted file mode 100644 index 34eb8c4e25..0000000000 --- a/test/testdata/References.hs +++ /dev/null @@ -1,9 +0,0 @@ -main = return () - -foo = bar - -bar = let x = bar 42 in const "hello" - -baz = do - x <- bar 23 - return $ bar 14 diff --git a/test/testdata/references/cabal.project b/test/testdata/references/cabal.project new file mode 100644 index 0000000000..f7ee9b8f81 --- /dev/null +++ b/test/testdata/references/cabal.project @@ -0,0 +1,2 @@ +packages: dependencyfoo/dependencyfoo.cabal + references.cabal diff --git a/test/testdata/references/dependencyfoo/dependencyfoo.cabal b/test/testdata/references/dependencyfoo/dependencyfoo.cabal new file mode 100644 index 0000000000..8a491a33ee --- /dev/null +++ b/test/testdata/references/dependencyfoo/dependencyfoo.cabal @@ -0,0 +1,12 @@ +cabal-version: >=1.10 + +name: dependencyfoo +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: ModuleInDependency + other-modules: OtherModuleInDependency + build-depends: base >=4.7 && <5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs b/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs new file mode 100644 index 0000000000..fc99118cac --- /dev/null +++ b/test/testdata/references/dependencyfoo/src/ModuleInDependency.hs @@ -0,0 +1,3 @@ +module ModuleInDependency where + +symbolDefinedInDependency = 3 diff --git a/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs b/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs new file mode 100644 index 0000000000..af1325bff9 --- /dev/null +++ b/test/testdata/references/dependencyfoo/src/OtherModuleInDependency.hs @@ -0,0 +1,5 @@ +module OtherModuleInDependency where + +symbolLocalToDependency = 4 + +someSymbol = symbolLocalToDependency diff --git a/test/testdata/references/exe/Main.hs b/test/testdata/references/exe/Main.hs new file mode 100644 index 0000000000..713f3808bf --- /dev/null +++ b/test/testdata/references/exe/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import ModuleInDependency + +main :: IO () +main = return () + +xxx = symbolDefinedInDependency + +a = 2 +b = a + 1 diff --git a/test/testdata/references/hie.yaml b/test/testdata/references/hie.yaml new file mode 100644 index 0000000000..8df59550ce --- /dev/null +++ b/test/testdata/references/hie.yaml @@ -0,0 +1,10 @@ +cradle: + cabal: + - path: "dependencyfoo/src" + component: "lib:dependencyfoo" + + - path: "src" + component: "lib:references" + + - path: "exe/Main.hs" + component: "references:exe:references" diff --git a/test/testdata/references/references.cabal b/test/testdata/references/references.cabal new file mode 100644 index 0000000000..35c290c58d --- /dev/null +++ b/test/testdata/references/references.cabal @@ -0,0 +1,18 @@ +cabal-version: >=1.10 + +name: references +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: OtherOtherModule, OtherModule, References + build-depends: base >=4.7 && <5 + hs-source-dirs: src + default-language: Haskell2010 + +executable references + main-is: Main.hs + build-depends: base >=4.7 && <5 + , dependencyfoo + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/test/testdata/references/src/OtherModule.hs b/test/testdata/references/src/OtherModule.hs new file mode 100644 index 0000000000..4840f46d8e --- /dev/null +++ b/test/testdata/references/src/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/test/testdata/references/src/OtherOtherModule.hs b/test/testdata/references/src/OtherOtherModule.hs new file mode 100644 index 0000000000..d567b8cb97 --- /dev/null +++ b/test/testdata/references/src/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/test/testdata/references/src/References.hs b/test/testdata/references/src/References.hs new file mode 100644 index 0000000000..ac76b4de40 --- /dev/null +++ b/test/testdata/references/src/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 From cc8a5824bff78e1560aad45f517886714a13b342 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Thu, 31 Dec 2020 19:32:04 -0600 Subject: [PATCH 04/10] Mark failing test. --- test/functional/TypeDefinition.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index f94ed27de1..d424e09fa5 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -9,6 +9,7 @@ import System.Directory import System.FilePath (()) import Test.Hls.Util import Test.Tasty +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit tests :: TestTree @@ -28,7 +29,8 @@ tests = testGroup "type definitions" [ $ getTypeDefinitionTest' (35, 16) 32 , testCase "find type-definition of type def in component" $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 - , testCase "find definition of parameterized data type" + , expectFailBecause "Why is this failing?" $ + testCase "find definition of parameterized data type" $ getTypeDefinitionTest' (40, 19) 37 ] From b31e69a53db26f4acfbb4b43c882f874063f733a Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 1 Jan 2021 11:42:05 -0600 Subject: [PATCH 05/10] Hlint fromRight hint. --- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 5 +++-- ghcide/src/Development/IDE/Spans/Documentation.hs | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 2647687720..45e8b6971c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -14,6 +14,7 @@ module Development.IDE.Plugin.Completions.Logic ( import Control.Applicative import Data.Char (isAlphaNum, isUpper) +import Data.Either (fromRight) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map @@ -337,13 +338,13 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do name' <- lookupName packageState m n return $ name' >>= safeTyThingForRecord - let recordCompls = case either (const Nothing) id record_ty of + let recordCompls = case fromRight Nothing record_ty of Just (ctxStr, flds) -> case flds of [] -> [] _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs imp'] Nothing -> [] - return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs imp'] ++ + return $ [mkNameCompItem n mn (fromRight Nothing ty) Nothing docs imp'] ++ recordCompls (unquals,quals) <- getCompls rdrElts diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index afbc67d6e2..6db64d56c0 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -69,7 +69,7 @@ mkDocMap env sources rm this_mod = lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing) lookupKind env mod = - fmap (either (const Nothing) id) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod + fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n] @@ -88,7 +88,7 @@ getDocumentationsTryGhc env mod sources names = do mkSpanDocText name = SpanDocText (getDocumentation sources name) <$> getUris name - + -- Get the uris to the documentation and source html pages if they exist getUris name = do let df = hsc_dflags env @@ -221,6 +221,6 @@ lookupHtmlForModule mkDocPath df m = do lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] lookupHtmls df ui = - -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path + -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows map takeDirectory . haddockInterfaces <$> lookupPackage df ui From fd9faec012657af6b761e853f7271e743d2f0070 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 1 Jan 2021 11:45:05 -0600 Subject: [PATCH 06/10] Hlint nubOrd. Update ignore annotation to point to correct function. This block of code that uses nub used to be part of main. But it got split off into a new function called runIde, and the hlint annotation was not updated to match. --- ghcide/exe/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 2c54d051f7..1ded0bee4f 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -267,7 +267,7 @@ runIde dir Arguments{..} hiedb hiechan = 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 From fc761a68d96bde986a317d2e20713ac72971f671 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 1 Jan 2021 12:58:02 -0600 Subject: [PATCH 07/10] Update tests to document that we now have references and workspace symbol providers. --- ghcide/test/exe/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d7bf6b2618..7bacd37edc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -121,10 +121,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 From 604b746a253adaaf8e956a16576a2c924982f683 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Fri, 1 Jan 2021 13:03:16 -0600 Subject: [PATCH 08/10] Fix line number in broken test. We have this code: 20: ddd :: Num a => a -> a -> a 21: ddd vv ww = vv +! ww The intention was to ask for the type definition of symbol "a" in line 20, and then assert that no type definitions were found. The reality is that the test was asking for the definition of the symbol at (20, 15) in 0-based indexing, which is the "!" in "+!". Until recently, ghcide could not find type definitions for "+!", so no type definitions were found and the test passed. But now, ghcide can find type definitions for "+!", and this test has begun to fail. The solution is to change (20, 15) to (19, 15), so that we ask for the type definitions of the symbol "a", which will not be found. --- ghcide/test/exe/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 7bacd37edc..4f5f8600d4 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2424,7 +2424,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) @@ -2438,6 +2438,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 ; From e75a69e6b40201b19845e4c2e1e8cabdb215a44a Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 3 Jan 2021 17:20:37 -0600 Subject: [PATCH 09/10] Update testcase. Getting a type definition can produce more than one result. E.g. the type of the symbol "pid" in: 1: data Parameter a = Parameter a 2: f :: forall a. Parameter a -> Parameter a 3: f pid = pid is (Parameter a), and the definition of this type is two part: the definition of Parameter on line 1, and the definition of a on line 2. --- test/functional/Reference.hs | 25 ++------------ test/functional/TypeDefinition.hs | 56 +++++++++++++------------------ test/utils/Test/Hls/Util.hs | 22 +++++++++++- 3 files changed, 46 insertions(+), 57 deletions(-) diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index 2e3ef040a0..8672a36d20 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -1,13 +1,9 @@ module Reference (tests) where -import Control.Lens import Control.Monad.IO.Class -import Control.Monad (forM) -import qualified Data.Set as Set +import Data.Tuple.Extra (first3) import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens -import System.Directory (canonicalizePath) import System.FilePath (()) import System.Time.Extra (sleep) import Test.Hls.Util @@ -136,10 +132,6 @@ tests = testGroup "references" ] ] --- | 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) - -- | When we ask for all references to symbol "foo", should the declaration "foo -- = 2" be among the references returned? data IncludeDeclaration = @@ -153,19 +145,6 @@ getReferences' (file, l, c) includeDeclaration = do where toBool YesIncludeDeclaration = True toBool NoExcludeDeclaration = False -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -actual `expectSameLocations` expected = do - let actual' = - Set.map (\location -> (location ^. uri - , location ^. range . start . line - , location ^. range . start . character)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath $ referencesPath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - referencesPath :: FilePath referencesPath = "test/testdata/references" @@ -189,4 +168,4 @@ referenceTest :: SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> Ass referenceTest loc includeDeclaration expected = referenceTestSession $ do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` expected + liftIO $ actual `expectSameLocations` map (first3 (referencesPath )) expected diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index d424e09fa5..aa9f0dec47 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -1,57 +1,47 @@ 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 -import Test.Tasty.ExpectedFailure (expectFailBecause) 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 17 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 - , expectFailBecause "Why is this failing?" $ - testCase "find definition of parameterized data type" - $ getTypeDefinitionTest' (40, 19) 37 + $ getTypeDefinitionTest ("src/Lib2.hs", 12, 20) [("src/Lib.hs", 7, 0)] + , testCase "find definition of parameterized data type" + $ 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 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 9fcd5331e9..f9c6873302 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 @@ -24,6 +25,7 @@ module Test.Hls.Util , logFilePath , noLogConfig , setupBuildToolFiles + , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -41,6 +43,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)) @@ -59,7 +62,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) @@ -423,3 +426,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' From 5e5d637ebb3747d5a93789909fe78b747cea37ab Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 3 Jan 2021 18:36:07 -0600 Subject: [PATCH 10/10] Kludge compilation for <=8.8.3. FunTy takes a third argument in 8.10.1 and on. --- ghcide/src/Development/IDE/GHC/Compat.hs | 9 +++++++++ ghcide/src/Development/IDE/Spans/AtPoint.hs | 5 ++--- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index f89703f725..8bfe757d9a 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, @@ -283,3 +285,10 @@ pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr #else pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #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/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 92addbbaf4..258a212663 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -32,7 +32,7 @@ import Development.IDE.Core.PositionMapping import Name import Outputable hiding ((<>)) import SrcLoc -import TyCoRep +import TyCoRep hiding (FunTy) import TyCon import qualified Var import NameEnv @@ -257,7 +257,7 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ hieKind) = AppTy a b -> getTypes [a,b] TyConApp tc ts -> tyConName tc : getTypes ts ForAllTy _ t -> getTypes [t] - FunTy _ a b -> getTypes [a,b] + FunTy a b -> getTypes [a,b] CastTy t _ -> getTypes [t] _ -> [] in fmap nubOrd $ concatMapM (fmap (maybe [] id) . nameToLocation hiedb lookupModule) (getTypes ts) @@ -338,4 +338,3 @@ pointCommand hf pos k = sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos cha = _character pos -