diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ ### unreleased +### 0.2.0 (2020-06-02) + +* Multi-component support (thanks @mpickering) +* Support for GHC 8.10 (thanks @sheaf and @chshersh) +* Fix some TH issues (thanks @mpickering) +* Automatically pick up changes to cradle dependencies (e.g. cabal + files) (thanks @jinwoo) +* Track dependencies when using `qAddDependentFile` (thanks @mpickering) +* Add record fields to document symbols outline (thanks @bubba) +* Fix some space leaks (thanks @mpickering) +* Strip redundant path information from diagnostics (thanks @tek) +* Fix import suggestions for operators (thanks @eddiemundo) +* Significant reductions in memory usage by using interfaces and `.hie` files (thanks + @pepeiborra) +* Minor improvements to completions +* More comprehensive suggestions for missing imports (thanks @pepeiborra) +* Group imports in document outline (thanks @fendor) +* Upgrade to haskell-lsp-0.22 (thanks @bubba) +* Upgrade to hie-bios 0.5 (thanks @fendor) + ### 0.1.0 (2020-02-04) * Code action for inserting new definitions (see #309). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,14 +25,41 @@ | Display type and source module of values | hover | | Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) | + +## Limitations to Multi-Component support + +`ghcide` supports loading multiple components into the same session so that +features such as go-to definition work across components. However, there are +some limitations to this. + +1. You will get much better results currently manually specifying the hie.yaml file. +Until tools like cabal and stack provide the right interface to support multi-component +projects, it is always advised to specify explicitly how your project partitions. +2. Cross-component features only work if you have loaded at least one file +from each component. +3. There is a known issue where if you have three components, such that A depends on B which depends on C +then if you load A and C into the session but not B then under certain situations you +can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for +a simple reproduction of the bug. + ## Using it ### Install `ghcide` #### With Nix -[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix) +Note that you need to compile `ghcide` with the same `ghc` as the project you are working on. +1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via + ``` + nix-env -iA haskellPackages.ghcide + ``` + or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`. + Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though. + +2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix) + which provides a `ghcide` via the `haskell.nix` infrastructure. + #### With Cabal or Stack First install the `ghcide` binary using `stack` or `cabal`, e.g. @@ -64,6 +91,10 @@ If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with. +### Optimal project setup + +`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. + ### Using with VS Code You can install the VSCode extension from the [VSCode @@ -203,8 +234,12 @@ ``` Here's a nice article on setting up neovim and coc: [Vim and Haskell in -2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) +2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide) +Here is a Docker container that pins down the build and configuration for +Neovim and ghcide on a minimal Debian 10 base system: +[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/). + ### SpaceVim In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`: @@ -248,11 +283,33 @@ This example above describes a setup in which `ghcide` is installed using `stack install ghcide` within a project. +### Using with Kakoune + +Install [kak-lsp](https://github.com/ul/kak-lsp). + +Change `kak-lsp.toml` to include this: + +```toml +[language.haskell] +filetypes = ["haskell"] +roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"] +command = "ghcide" +args = ["--lsp"] +``` + ## Hacking on ghcide To build and work on `ghcide` itself, you can use Stack or cabal, e.g., running `stack test` will execute the test suite. +If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`. +If you are chasing down test failures, you can use the tasty-rerun feature by running tests as + + stack --stack-yaml=stack84.yaml test --test-arguments "--rerun" + +This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. +See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. + ### Building the extension For development, you can also the VSCode extension from this repository (see @@ -268,8 +325,10 @@ ## History and relationship to other Haskell IDE's +The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server). + The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE). -The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that has been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors. +The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/). diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -12,6 +12,8 @@ ,argFiles :: [FilePath] ,argsVersion :: Bool ,argsShakeProfiling :: Maybe FilePath + ,argsTesting :: Bool + ,argsThreads :: Int } getArguments :: IO Arguments @@ -29,3 +31,5 @@ <*> 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 "test" <> help "Enable additional lsp messages used by the testsuite") + <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -3,19 +3,31 @@ {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# LANGUAGE CPP #-} -- To get precise GHC version {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Main(main) where +import Linker (initDynLinker) +import Data.IORef +import NameCache +import Packages +import Module import Arguments -import Data.Maybe -import Data.List.Extra -import System.FilePath +import Control.Concurrent.Async import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import Data.Default -import System.Time.Extra +import Data.Either +import Data.Function +import Data.List.Extra +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Clock (UTCTime) +import Data.Version +import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest import Development.IDE.Core.Service @@ -31,31 +43,39 @@ import Development.IDE.Plugin import Development.IDE.Plugin.Completions as Completions import Development.IDE.Plugin.CodeAction as CodeAction -import qualified Data.Text as T -import qualified Data.Text.IO as T +import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types (LspId(IdInt)) -import Linker -import Data.Version +import Language.Haskell.LSP.Types +import Data.Aeson (ToJSON(toJSON)) import Development.IDE.LSP.LanguageServer -import System.Directory.Extra as IO +import qualified System.Directory.Extra as IO import System.Environment import System.IO import System.Exit +import System.FilePath +import System.Directory +import System.Time.Extra +import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute) import Paths_ghcide import Development.GitRev import Development.Shake (Action, action) -import qualified Data.Set as Set +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map - +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Base16 (encode) +import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..)) +import GhcMonad +import HscTypes (HscEnv(..), ic_dflags) import GHC hiding (def) -import qualified GHC.Paths +import GHC.Check ( VersionCheck(..), makeGhcVersionChecker ) +import Data.Either.Extra -import HIE.Bios +import HIE.Bios.Cradle +import HIE.Bios.Types --- Set the GHC libdir to the nix libdir if it's present. -getLibdir :: IO FilePath -getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" +import Utils ghcideVersion :: IO String ghcideVersion = do @@ -82,74 +102,68 @@ let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - whenJust argsCwd setCurrentDirectory + whenJust argsCwd IO.setCurrentDirectory - dir <- getCurrentDirectory + dir <- IO.getCurrentDirectory + command <- makeLspCommandId "typesignature.add" let plugins = Completions.plugin <> CodeAction.plugin + onInitialConfiguration = const $ Right () + onConfigurationChange = const $ Right () + options = def { LSP.executeCommandCommands = Just [command] + , LSP.completionTriggerCharacters = Just "." + } if argLSP then do t <- offsetTime hPutStrLn stderr "Starting LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do + runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t - -- very important we only call loadSession once, and it's fast, so just do it before starting - session <- loadSession dir - let options = (defaultIdeOptions $ return session) + let options = (defaultIdeOptions $ loadSessionShake dir) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling + , optTesting = argsTesting + , optThreads = argsThreads } - initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs + debouncer <- newAsyncDebouncer + initialise caps (mainRule >> pluginRules plugins >> action kick) + getLspId event (logger minBound) debouncer options vfs else do + -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + putStrLn $ "Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues" - putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir + putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir files <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM canonicalizePath files + files <- nubOrd <$> mapM IO.canonicalizePath files putStrLn $ "Found " ++ show (length files) ++ " files" - putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup" + putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" cradles <- mapM findCradle files let ucradles = nubOrd cradles let n = length ucradles putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] - sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do - let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x - putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg - cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x - when (isNothing x) $ print cradle - putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session" - cradleToSession cradle - - putStrLn "\nStep 5/6: Initializing the IDE" + putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle - let cradlesToSessions = Map.fromList $ zip ucradles sessions - let filesToCradles = Map.fromList $ zip files cradles - let grab file = fromMaybe (head sessions) $ do - cradle <- Map.lookup file filesToCradles - Map.lookup cradle cradlesToSessions - - let options = - (defaultIdeOptions $ return $ return . grab) - { optShakeProfiling = argsShakeProfiling } - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs + debouncer <- newAsyncDebouncer + ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs - putStrLn "\nStep 6/6: Type checking the files" - setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files - results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files + putStrLn "\nStep 4/4: Type checking the files" + setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files + results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files) let (worked, failed) = partition fst $ zip (map isJust results) files when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)" - - unless (null failed) exitFailure - + return () expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do @@ -158,7 +172,7 @@ let recurse "." = True recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x + files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files @@ -167,48 +181,414 @@ kick :: Action () kick = do files <- getFilesOfInterest - void $ uses TypeCheck $ Set.toList files + void $ uses TypeCheck $ HashSet.toList files -- | Print an LSP event. showEvent :: Lock -> FromServerMessage -> IO () showEvent _ (EventFileDiagnostics _ []) = return () -showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = +showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e -cradleToSession :: Cradle a -> IO HscEnvEq -cradleToSession cradle = do - cradleRes <- getCompilerOptions "" cradle - opts <- case cradleRes of - CradleSuccess r -> pure r - CradleFail err -> throwIO err - -- TODO Rather than failing here, we should ignore any files that use this cradle. - -- That will require some more changes. - CradleNone -> fail "'none' cradle is not yet supported" +-- | Run the specific cradle on a specific FilePath via hie-bios. +cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions) +cradleToSessionOpts cradle file = do + let showLine s = putStrLn ("> " ++ s) + cradleRes <- runCradle (cradleOptsProg cradle) showLine file + case cradleRes of + CradleSuccess r -> pure (Right r) + CradleFail err -> return (Left [err]) + -- For the None cradle perhaps we still want to report an Info + -- message about the fact that the file is being ignored. + CradleNone -> return (Left []) + +emptyHscEnv :: IO HscEnv +emptyHscEnv = do libdir <- getLibdir - env <- runGhc (Just libdir) $ do - _targets <- initSession opts - getSession + env <- runGhc (Just libdir) getSession initDynLinker env - newHscEnvEq env + pure env +-- | Convert a target to a list of potential absolute paths. +-- A TargetModule can be anywhere listed by the supplied include +-- directories +-- A target file is a relative path but with a specific prefix so just need +-- to canonicalise it. +targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath] +targetToFile is (TargetModule mod) = do + let fps = [i moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ] + exts = ["hs", "hs-boot", "lhs"] + mapM (fmap toNormalizedFilePath' . canonicalizePath) fps +targetToFile _ (TargetFile f _) = do + f' <- canonicalizePath f + return [toNormalizedFilePath' f'] -loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq) -loadSession dir = do - cradleLoc <- memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/digital-asset/ghcide/issues/126 - res' <- traverse makeAbsolute res - return $ normalise <$> res' - session <- memoIO $ \file -> do - c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file - cradleToSession c - return $ \file -> liftIO $ session =<< cradleLoc file +setNameCache :: IORef NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } +loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq)) +loadSessionShake fp = do + se <- getShakeExtras + IdeOptions{optTesting} <- getIdeOptions + res <- liftIO $ loadSession optTesting se fp + return (fmap liftIO res) +-- | This is the key function which implements multi-component support. All +-- components mapping to the same hie.yaml file are mapped to the same +-- HscEnv which is updated as new components are discovered. +loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq)) +loadSession optTesting ShakeExtras{logger, eventer} dir = do + -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file + hscEnvs <- newVar Map.empty :: IO (Var HieMap) + -- Mapping from a Filepath to HscEnv + fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) + + -- This caches the mapping from Mod.hs -> hie.yaml + cradleLoc <- memoIO $ \v -> do + res <- findCradle v + -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path + -- try and normalise that + -- e.g. see https://github.com/digital-asset/ghcide/issues/126 + res' <- traverse IO.makeAbsolute res + return $ normalise <$> res' + + -- Create a new HscEnv from a hieYaml root and a set of options + -- If the hieYaml file already has an HscEnv, the new component is + -- combined with the components in the old HscEnv into a new HscEnv + -- which contains the union. + let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) + -> IO (HscEnv, ComponentInfo, [ComponentInfo]) + packageSetup (hieYaml, cfp, opts) = do + -- Parse DynFlags for the newly discovered component + hscEnv <- emptyHscEnv + (df, targets) <- evalGhcEnv hscEnv $ + setOptions opts (hsc_dflags hscEnv) + dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml) + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + modifyVar hscEnvs $ \m -> do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info + : maybe [] snd oldDeps + -- Get all the unit-ids for things in this component + inplace = map rawComponentUnitId new_deps + + new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do + -- Remove all inplace dependencies from package flags for + -- components in this HscEnv + let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2 + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo rawComponentUnitId + processed_df + uids + rawComponentTargets + rawComponentFP + rawComponentCOptions + rawComponentDependencyInfo + -- Make a new HscEnv, we have to recompile everything from + -- scratch again (for now) + -- It's important to keep the same NameCache though for reasons + -- that I do not fully understand + logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + hscEnv <- case oldDeps of + Nothing -> emptyHscEnv + Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv + newHscEnv <- + -- Add the options for the current component to the HscEnv + evalGhcEnv hscEnv $ do + _ <- setSessionDynFlags df + getSession + -- Modify the map so the hieYaml now maps to the newly created + -- HscEnv + -- Returns + -- . the new HscEnv so it can be used to modify the + -- FilePath -> HscEnv map (fileToFlags) + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) + + let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq) + session (hieYaml, cfp, opts) = do + (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts) + -- Make a map from unit-id to DynFlags, this is used when trying to + -- resolve imports. (especially PackageImports) + let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + + -- New HscEnv for the component in question, returns the new HscEnvEq and + -- a mapping from FilePath to the newly created HscEnvEq. + let new_cache = newComponentCache logger hscEnv uids + (cs, res) <- new_cache new + -- Modified cache targets for everything else in the hie.yaml file + -- which now uses the same EPS and so on + cached_targets <- concatMapM (fmap fst . new_cache) old_deps + modifyVar_ fileToFlags $ \var -> do + pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var + + return (fst res) + + let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq) + consultCradle hieYaml cfp = do + when optTesting $ eventer $ notifyCradleLoaded cfp + logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp) + cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + eopts <- cradleToSessionOpts cradle cfp + logDebug logger $ T.pack ("Session loading result: " <> show eopts) + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right opts -> do + session (hieYaml, toNormalizedFilePath' cfp, opts) + -- Failure case, either a cradle error or the none cradle + Left err -> do + dep_info <- getDependencyInfo (maybeToList hieYaml) + let ncfp = toNormalizedFilePath' cfp + let res = (map (renderCradleError ncfp) err, Nothing) + modifyVar_ fileToFlags $ \var -> do + pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var + return res + + -- This caches the mapping from hie.yaml + Mod.hs -> [String] + let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq) + sessionOpts (hieYaml, file) = do + v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags + cfp <- canonicalizePath file + case HM.lookup (toNormalizedFilePath' cfp) v of + Just (opts, old_di) -> do + deps_ok <- checkDependencyInfo old_di + if not deps_ok + then do + -- If the dependencies are out of date then clear both caches and start + -- again. + modifyVar_ fileToFlags (const (return Map.empty)) + -- Keep the same name cache + modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) + consultCradle hieYaml cfp + else return opts + Nothing -> consultCradle hieYaml cfp + + dummyAs <- async $ return (error "Uninitialised") + runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq))) + -- The main function which gets options for a file. We only want one of these running + -- at a time. Therefore the IORef contains the currently running cradle, if we try + -- to get some more options then we wait for the currently running action to finish + -- before attempting to do so. + let getOptions :: FilePath -> IO (IdeResult HscEnvEq) + getOptions file = do + hieYaml <- cradleLoc file + sessionOpts (hieYaml, file) + return $ \file -> do + join $ mask_ $ modifyVar runningCradle $ \as -> do + -- If the cradle is not finished, then wait for it to finish. + void $ wait as + as <- async $ getOptions file + return (as, wait as) + + + +-- | Create a mapping from FilePaths to HscEnvEqs +newComponentCache + :: Logger + -> HscEnv + -> [(InstalledUnitId, DynFlags)] + -> ComponentInfo + -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo)) +newComponentCache logger hsc_env uids ci = do + let df = componentDynFlags ci + let hscEnv' = hsc_env { hsc_dflags = df + , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + + versionMismatch <- checkGhcVersion + henv <- case versionMismatch of + Just mismatch -> return mismatch + Nothing -> newHscEnvEq hscEnv' uids + let res = (([], Just henv), componentDependencyInfo ci) + logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + + let is = importPaths df + ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci) + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- Otherwise, we will immediately attempt to reload this module which + -- causes an infinite loop and high CPU usage. + let special_target = (componentFP ci, res) + let xs = map (,res) ctargets + return (special_target:xs, res) + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags +setCacheDir logger prefix hscComponents comps dflags = do + cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps) + liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir + pure $ dflags + & setHiDir cacheDir + & setDefaultHieDir cacheDir + + +renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic +renderCradleError nfp (CradleError _ec t) = + ideErrorText nfp (T.unlines (map T.pack t)) + +-- See Note [Multi Cradle Dependency Info] +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) +type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) +type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) + +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: InstalledUnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: InstalledUnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | Internal units, such as local libraries, that this component + -- is loaded with. These have been extracted from the original + -- ComponentOptions. + , componentInternalUnits :: [InstalledUnitId] + -- | All targets of this components. + , componentTargets :: [Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + tryIO :: IO a -> IO (Either IOException a) + tryIO = try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) + +-- | This function removes all the -package flags which refer to packages we +-- are going to deal with ourselves. For example, if a executable depends +-- on a library component, then this function will remove the library flag +-- from the package flags for the executable +-- +-- There are several places in GHC (for example the call to hptInstances in +-- tcRnImports) which assume that all modules in the HPT have the same unit +-- ID. Therefore we create a fake one and give them all the same unit id. +removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) +removeInplacePackages us df = (df { packageFlags = ps + , thisInstalledUnitId = fake_uid }, uids) + where + (uids, ps) = partitionEithers (map go (packageFlags df)) + fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") + go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us + then Left (toInstalledUnitId u) + else Right p + go p = Right p + -- | Memoize an IO function, with the characteristics: -- -- * If multiple people ask for a result simultaneously, make sure you only compute it once. @@ -225,3 +605,79 @@ res <- onceFork $ op k return (Map.insert k res mp, res) Just res -> return (mp, res) + +setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) +setOptions (ComponentOptions theOpts compRoot _) dflags = do + (dflags', targets) <- addCmdOpts theOpts dflags + let dflags'' = + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation $ + makeDynFlagsAbsolute compRoot dflags' + -- initPackages parses the -package flags and + -- sets up the visibility for each component. + (final_df, _) <- liftIO $ initPackages dflags'' + return (final_df, targets) + + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +getCacheDir :: String -> [String] -> IO FilePath +getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir prefix ++ "-" ++ opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +notifyCradleLoaded :: FilePath -> FromServerMessage +notifyCradleLoaded fp = + NotCustomServer $ + NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ + toJSON fp + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +ghcVersionChecker :: IO VersionCheck +ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir)) + +checkGhcVersion :: IO (Maybe HscEnvEq) +checkGhcVersion = do + res <- ghcVersionChecker + case res of + Failure err -> do + putStrLn $ "Error while checking GHC version: " ++ show err + return Nothing + Mismatch {..} -> + return $ Just GhcVersionMismatch {..} + _ -> + return Nothing diff --git a/exe/Utils.hs b/exe/Utils.hs new file mode 100644 --- /dev/null +++ b/exe/Utils.hs @@ -0,0 +1,9 @@ +module Utils (getLibdir) where + +import qualified GHC.Paths +import System.Environment +import Data.Maybe + +-- Set the GHC libdir to the nix libdir if it's present. +getLibdir :: IO FilePath +getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,12 +2,12 @@ build-type: Simple category: Development name: ghcide -version: 0.1.0 +version: 0.2.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset maintainer: Digital Asset -copyright: Digital Asset 2018-2019 +copyright: Digital Asset 2018-2020 synopsis: The core of an IDE description: A library for building Haskell IDE's on top of the GHC API. @@ -15,7 +15,13 @@ bug-reports: https://github.com/digital-asset/ghcide/issues tested-with: GHC==8.6.5 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md - test/data/GotoHover.hs + test/data/hover/*.hs + test/data/multi/cabal.project + test/data/multi/hie.yaml + test/data/multi/a/a.cabal + test/data/multi/a/*.hs + test/data/multi/b/b.cabal + test/data/multi/b/*.hs source-repository head type: git @@ -30,6 +36,7 @@ default-language: Haskell2010 build-depends: aeson, + array, async, base == 4.*, binary, @@ -43,8 +50,8 @@ filepath, haddock-library >= 1.8, hashable, - haskell-lsp-types == 0.19.*, - haskell-lsp == 0.19.*, + haskell-lsp-types == 0.22.*, + haskell-lsp == 0.22.*, mtl, network-uri, prettyprinter-ansi-terminal, @@ -60,7 +67,7 @@ text, time, transformers, - unordered-containers, + unordered-containers >= 0.2.10.0, utf8-string, hslogger if flag(ghc-lib) @@ -73,8 +80,11 @@ ghc-boot-th, ghc-boot, ghc >= 8.4 - if !os(windows) + if os(windows) build-depends: + Win32 + else + build-depends: unix c-sources: cbits/getmodtime.c @@ -99,7 +109,10 @@ include-dirs: include exposed-modules: + Development.IDE.Compat + Development.IDE.Core.Debouncer Development.IDE.Core.FileStore + Development.IDE.Core.IdeConfiguration Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping Development.IDE.Core.Rules @@ -109,7 +122,9 @@ Development.IDE.GHC.Error Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation + Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer + Development.IDE.LSP.Outline Development.IDE.LSP.Protocol Development.IDE.LSP.Server Development.IDE.Spans.Common @@ -121,7 +136,6 @@ Development.IDE.Plugin.Completions Development.IDE.Plugin.CodeAction other-modules: - Development.IDE.Core.Debouncer Development.IDE.Core.Compile Development.IDE.Core.Preprocessor Development.IDE.Core.FileExists @@ -129,22 +143,32 @@ Development.IDE.GHC.CPP Development.IDE.GHC.Orphans Development.IDE.GHC.Warnings + Development.IDE.GHC.WithDynFlags Development.IDE.Import.FindImports - Development.IDE.LSP.HoverDefinition Development.IDE.LSP.Notifications - Development.IDE.LSP.Outline Development.IDE.Spans.AtPoint Development.IDE.Spans.Calculate Development.IDE.Spans.Documentation Development.IDE.Spans.Type + Development.IDE.Plugin.CodeAction.PositionIndexed + Development.IDE.Plugin.CodeAction.Rules + Development.IDE.Plugin.CodeAction.RuleTypes Development.IDE.Plugin.Completions.Logic Development.IDE.Plugin.Completions.Types + if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib) + hs-source-dirs: src-ghc88 + other-modules: + Development.IDE.GHC.HieAst + if (impl(ghc > 8.9)) + hs-source-dirs: src-ghc810 + other-modules: + Development.IDE.GHC.HieAst ghc-options: -Wall -Wno-name-shadowing executable ghcide-test-preprocessor default-language: Haskell2010 hs-source-dirs: test/preprocessor - ghc-options: -Wall + ghc-options: -Wall -Wno-name-shadowing main-is: Main.hs build-depends: base == 4.* @@ -166,29 +190,52 @@ "-with-rtsopts=-I0 -qg -A128M" main-is: Main.hs build-depends: + time, + async, hslogger, + aeson, base == 4.*, + binary, + base16-bytestring >=0.1.1 && <0.2, + bytestring, containers, + cryptohash-sha1 >=0.11.100 && <0.12, data-default, + deepseq, directory, extra, filepath, + ghc-check >= 0.3.0.1 && < 0.4, ghc-paths, ghc, gitrev, + hashable, haskell-lsp, - hie-bios >= 0.4.0 && < 0.5, + haskell-lsp-types, + hie-bios >= 0.5.0 && < 0.6, ghcide, optparse-applicative, shake, - text + text, + unordered-containers other-modules: + Utils Arguments Paths_ghcide default-extensions: + BangPatterns + DeriveFunctor + DeriveGeneric + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedStrings RecordWildCards + ScopedTypeVariables + StandaloneDeriving TupleSections + TypeApplications ViewPatterns test-suite ghcide-tests @@ -220,16 +267,19 @@ haddock-library, haskell-lsp, haskell-lsp-types, + network-uri, lens, - lsp-test >= 0.8, + lsp-test >= 0.11.0.1 && < 0.12, parser-combinators, QuickCheck, quickcheck-instances, rope-utf16-splay, + shake, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, + tasty-rerun, text hs-source-dirs: test/cabal test/exe test/src include-dirs: include diff --git a/src-ghc810/Development/IDE/GHC/HieAst.hs b/src-ghc810/Development/IDE/GHC/HieAst.hs new file mode 100644 --- /dev/null +++ b/src-ghc810/Development/IDE/GHC/HieAst.hs @@ -0,0 +1,1928 @@ + + +{- +Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile + +Main functions for .hie file generation +-} +{- HLINT ignore -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Development.IDE.GHC.HieAst ( mkHieFile ) where + +import GhcPrelude + +import Avail ( Avails ) +import Bag ( Bag, bagToList ) +import BasicTypes +import BooleanFormula +import Class ( FunDep ) +import CoreUtils ( exprType ) +import ConLike ( conLikeName ) +import Desugar ( deSugarExpr ) +import FieldLabel +import GHC.Hs +import HscTypes +import Module ( ModuleName, ml_hs_file ) +import MonadUtils ( concatMapM, liftIO ) +import Name ( Name, nameSrcSpan, setNameLoc ) +import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import SrcLoc +import TcHsSyn ( hsLitType, hsPatType ) +import Type ( mkVisFunTys, Type ) +import TysWiredIn ( mkListTy, mkSumTy ) +import Var ( Id, Var, setVarName, varName, varType ) +import TcRnTypes +import MkIface ( mkIfaceExports ) +import Panic + +import HieTypes +import HieUtils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List ( foldl1' ) +import Data.Maybe ( listToMaybe ) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +{- Note [Updating HieAst for changes in the GHC AST] + +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `HieTypes`, and looks like + +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in HieAst. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in main/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +newtype HieState = HieState + { name_remapping :: NameEnv Id + } + +initState :: HieState +initState = HieState emptyNameEnv + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT HieState Hsc + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource + -> BS.ByteString -> Hsc HieFile +mkHieFile ms ts rs src = do + let tc_binds = tcg_binds ts + (asts', arr) <- getCompressedAsts tc_binds rs + let Just src_file = ml_hs_file $ ms_location ms + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs = do + asts <- enrichHie ts rs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + let spanFile children = case children of + [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + modulify xs = + Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs + + asts = HieASTs + $ resolveTyVarScopes + $ M.map (modulify . mergeSortAsts) + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = panic "XGRHS has no span" + +bindingsOnly :: [Context Name] -> [HieAST a] +bindingsOnly [] = [] +bindingsOnly (C c n : xs) = case nameSrcSpan n of + RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> bindingsOnly xs + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local tranformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ + listScopes patScope (map dL xs) + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr a] + -> [TVScoped (LHsTyVarBndr a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here +Because of HsWC and HsIB pass on their scope to their children +we must wrap the LHsType in pattern signatures in a +Shielded explictly, so that the HsWC/HsIB scope is not passed +on the the LHsType +-} + +data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead + +type family ProtectedSig a where + ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs + GhcRn + (Shielded (LHsType GhcRn))) + ProtectedSig GhcTc = NoExtField + +class ProtectSig a where + protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a + +instance (HasLoc a) => HasLoc (Shielded a) where + loc (SH _ a) = loc a + +instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where + toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) + +instance ProtectSig GhcTc where + protectSig _ _ = noExtField + +instance ProtectSig GhcRn where + protectSig sc (HsWC a (HsIB b sig)) = + HsWC a (HsIB b (SH sc sig)) + protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec + protectSig _ (XHsWildCardBndrs nec) = noExtCon nec + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance HasLoc a => HasLoc (FamEqn s a) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + loc _ = noSrcSpan + +{- Note [Real DataCon Name] +The typechecker subtitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (Context (Located NoExtField)) where + toHie _ = pure [] + +instance ToHie (TScoped NoExtField) where + toHie _ = pure [] + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span) mname)) = + pure $ [Node (NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') + -> do + m <- asks name_remapping + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just $ varType name') + (S.singleton context))) + span + []] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') -> do + m <- asks name_remapping + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +-- | Dummy instances - never called +instance ToHie (TScoped (LHsSigWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped (LHsWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (SigContext (LSig GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped Type) where + toHie _ = pure [] + +instance HasType (LHsBind GhcRn) where + getTypeNode (L spn bind) = makeNode bind spn + +instance HasType (LHsBind GhcTc) where + getTypeNode (L spn bind) = case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HasType (Located (Pat GhcRn)) where + getTypeNode (dL -> L spn pat) = makeNode pat spn + +instance HasType (Located (Pat GhcTc)) where + getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) + +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = lift $ + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr a -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + HsWrap{} -> False + _ -> True + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a (LHsExpr a)) + , ToHie (LHsExpr a) + , ToHie (Located (PatSynBind a a)) + , HasType (LHsBind a) + , ModifyState (IdP a) + , Data (HsBind a) + ) => ToHie (BindContext (LHsBind a)) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{abs_exports = xs, abs_binds = binds} -> + [ local (modifyState xs) $ -- Note [Name Remapping] + toHie $ fmap (BC context scope) binds + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + XHsBindsLR _ -> [] + +instance ( ToHie (LMatch a body) + ) => ToHie (MatchGroup a body) where + toHie mg = concatM $ case mg of + MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> + [ pure $ locOnly span + , toHie alts + ] + MG{} -> [] + XMatchGroup _ -> [] + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (HsPatSynDir a) + ) => ToHie (Located (PatSynBind a a)) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope NoScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + XPatSynBind _ -> [] + +instance ( ToHie (MatchGroup a (LHsExpr a)) + ) => ToHie (HsPatSynDir a) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( a ~ GhcPass p + , ToHie body + , ToHie (HsMatchContext (NameOrRdrName (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a body) + , Data (Match a body) + ) => ToHie (LMatch (GhcPass p) body) where + toHie (L span m ) = concatM $ makeNode m span : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + XMatch _ -> [] + +instance ( ToHie (Context (Located a)) + ) => ToHie (HsMatchContext a) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( ToHie (HsMatchContext a) + ) => ToHie (HsStmtContext a) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) + , ToHie (LHsExpr a) + , ToHie (TScoped (LHsSigWcType a)) + , ProtectSig a + , ToHie (TScoped (ProtectedSig a)) + , HasType (LPat a) + , Data (HsSplice a) + ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope (dL pat)) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPatIn c dets -> + [ toHie $ C Use c + , toHie $ contextify dets + ] + ConPatOut {pat_con = con, pat_args = dets}-> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , let cscope = mkLScope (dL pat) in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + (protectSig @a cscope sig) + -- See Note [Scoping Rules for SigPat] + ] + CoPat _ _ _ _ -> + [] + XPat _ -> [] + where + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + +instance ( ToHie body + , ToHie (LGRHS a body) + , ToHie (RScoped (LHsLocalBinds a)) + ) => ToHie (GRHSs a body) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + XGRHSs _ -> [] + +instance ( ToHie (Located body) + , ToHie (RScoped (GuardLStmt a)) + , Data (GRHS a (Located body)) + ) => ToHie (LGRHS a (Located body)) where + toHie (L span g) = concatM $ makeNode g span : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + XGRHS _ -> [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , HasType (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (LGRHS a (LHsExpr a)) + , ToHie (RContext (HsRecordBinds a)) + , ToHie (RFContext (Located (AmbiguousFieldOcc a))) + , ToHie (ArithSeqInfo a) + , ToHie (LHsCmdTop a) + , ToHie (RScoped (GuardLStmt a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (TScoped (LHsWcType (NoGhcTc a))) + , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) + , Data (HsExpr a) + , Data (HsSplice a) + , Data (HsTupArg a) + , Data (AmbiguousFieldOcc a) + , (HasRealDataConName a) + ) => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @a mrealcon name) + -- See Note [Real DataCon Name] + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsSCC _ _ _ expr -> + [ toHie expr + ] + HsCoreAnn _ _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsTickPragma _ _ _ _ expr -> + [ toHie expr + ] + HsWrap _ _ a -> + [ toHie $ L mspan a + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + XExpr _ -> [] + +instance ( a ~ GhcPass p + , ToHie (LHsExpr a) + , Data (HsTupArg a) + ) => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + XTupArg _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (RScoped (ApplicativeArg a)) + , ToHie (Located body) + , Data (StmtLR a a (Located body)) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body _ _ -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + XStmtLR _ -> [] + +instance ( ToHie (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (LHsLocalBinds a)) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ _ -> [] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + XHsLocalBindsLR _ -> [] + +instance ( ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (XXValBindsLR a a)) + ) => ToHie (RScoped (HsValBindsLR a a)) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance ToHie (RScoped (NHsValBindsLR GhcTc)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] +instance ToHie (RScoped (NHsValBindsLR GhcRn)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie (RContext (LHsRecField a arg)) + ) => ToHie (RContext (HsRecFields a arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg + , HasLoc arg + , Data label + , Data arg + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +removeDefSrcSpan :: Name -> Name +removeDefSrcSpan n = setNameLoc n noSrcSpan + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name + ] + Ambiguous _name _ -> + [ ] + XAmbiguousFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + Ambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XAmbiguousFieldOcc _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (StmtLR a a (Located (HsExpr a))) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + toHie (RS _ (XApplicativeArg _)) = pure [] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance ( ToHie (LHsCmd a) + , Data (HsCmdTop a) + ) => ToHie (LHsCmdTop a) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + XCmdTop _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (MatchGroup a (LHsCmd a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsCmd a) + , Data (HsCmdTop a) + , Data (StmtLR a a (Located (HsCmd a))) + , Data (HsLocalBinds a) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + HsCmdWrap _ _ _ -> [] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + toHie (XTyClGroup _) = pure [] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (pure . locOnly . getLoc) deftyps + , toHie deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + XTyClDecl _ -> [] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + XFamilyDecl _ -> [] + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (pure . locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + XFamilyResultSig _ -> [] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie rhs, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn rhs)) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + toHie (XFamEqn _) = pure [] + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + toHie (XHsDataDefn _) = pure [] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ pure $ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , pure $ locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + XHsDerivingClause _ -> [] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = pure $ locOnly span + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = qvars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + XConDecl _ -> [] + where condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs + InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ pure $ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsImplicitBndrs _)) = pure [] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsWildCardBndrs _)) = pure [] + +instance ToHie (LStandaloneKindSig GhcRn) where + toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + XStandaloneKindSig _ -> [] + +instance ToHie (SigContext (LSig GhcRn)) where + toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , pure $ maybe [] (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ pure $ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + XSig _ -> [] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ _ bndrs body -> + [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ a b -> + [ toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = pure $ locOnly sp + +instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + XTyVarBndr _ -> [] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ pure $ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + toHie (TS _ (XLHsQTyVars _)) = pure [] + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ pure $ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + XConDeclField _ -> [] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + XSpliceDecl _ -> [] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance ( ToHie (LHsExpr a) + , Data (HsSplice a) + ) => ToHie (Located (HsSplice a)) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ pure $ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + HsSplicedT _ -> + [] + XSplice _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (pure . locOnly . getLoc) roles + ] + XRoleAnnotDecl _ -> [] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + XInstDecl _ -> [] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + XDerivDecl _ -> [] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + XFixitySig _ -> [] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + XDefaultDecl _ -> [] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + XForeignDecl _ -> [] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = pure $ concat $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + XWarnDecls _ -> [] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + XWarnDecl _ -> [] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + XAnnDecl _ -> [] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + XRuleDecls _ -> [] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L _ (XRuleDecl _)) = pure [] + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , pure $ locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + XRuleBndr _ -> [] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + XImportDecl _ -> [] + where + goIE (hiding, (L sp liens)) = concatM $ + [ pure $ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + XIE _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] diff --git a/src-ghc88/Development/IDE/GHC/HieAst.hs b/src-ghc88/Development/IDE/GHC/HieAst.hs new file mode 100644 --- /dev/null +++ b/src-ghc88/Development/IDE/GHC/HieAst.hs @@ -0,0 +1,1789 @@ + +{- +Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile + +Main functions for .hie file generation +-} +{- HLINT ignore -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Development.IDE.GHC.HieAst ( mkHieFile ) where + +import Avail ( Avails ) +import Bag ( Bag, bagToList ) +import BasicTypes +import BooleanFormula +import Class ( FunDep ) +import CoreUtils ( exprType ) +import ConLike ( conLikeName ) +import Desugar ( deSugarExpr ) +import FieldLabel +import HsSyn +import HscTypes +import Module ( ModuleName, ml_hs_file ) +import MonadUtils ( concatMapM, liftIO ) +import Name ( Name, nameSrcSpan, setNameLoc ) +import SrcLoc +import TcHsSyn ( hsLitType, hsPatType ) +import Type ( mkFunTys, Type ) +import TysWiredIn ( mkListTy, mkSumTy ) +import Var ( Id, Var, setVarName, varName, varType ) +import TcRnTypes +import MkIface ( mkIfaceExports ) + +import HieTypes +import HieUtils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List (foldl', foldl1' ) +import Data.Maybe ( listToMaybe ) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +-- These synonyms match those defined in main/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +newtype HieState = HieState + { name_remapping :: M.Map Name Id + } + +initState :: HieState +initState = HieState M.empty + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT HieState Hsc + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource + -> BS.ByteString + -> Hsc HieFile +mkHieFile ms ts rs src = do + let tc_binds = tcg_binds ts + (asts', arr) <- getCompressedAsts tc_binds rs + let Just src_file = ml_hs_file $ ms_location ms + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs = do + asts <- enrichHie ts rs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + let spanFile children = case children of + [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + modulify xs = + Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs + + asts = HieASTs + $ resolveTyVarScopes + $ M.map (modulify . mergeSortAsts) + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = error "XGRHS has no span" + +bindingsOnly :: [Context Name] -> [HieAST a] +bindingsOnly [] = [] +bindingsOnly (C c n : xs) = case nameSrcSpan n of + RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> bindingsOnly xs + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local tranformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $ + listScopes patScope (map dL xs) + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr a] + -> [TVScoped (LHsTyVarBndr a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here +Because of HsWC and HsIB pass on their scope to their children +we must wrap the LHsType in pattern signatures in a +Shielded explictly, so that the HsWC/HsIB scope is not passed +on the the LHsType +-} + +data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead + +type family ProtectedSig a where + ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs + GhcRn + (Shielded (LHsType GhcRn))) + ProtectedSig GhcTc = NoExt + +class ProtectSig a where + protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a + +instance (HasLoc a) => HasLoc (Shielded a) where + loc (SH _ a) = loc a + +instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where + toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) + +instance ProtectSig GhcTc where + protectSig _ _ = NoExt + +instance ProtectSig GhcRn where + protectSig sc (HsWC a (HsIB b sig)) = + HsWC a (HsIB b (SH sc sig)) + protectSig _ _ = error "protectSig not given HsWC (HsIB)" + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + loc _ = noSrcSpan + +instance HasLoc (Pat (GhcPass a)) where + loc (dL -> L l _) = l + +-- | The main worker class +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (Context (Located NoExt)) where + toHie _ = pure [] + +instance ToHie (TScoped NoExt) where + toHie _ = pure [] + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span) mname)) = + pure $ [Node (NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') + -> do + m <- asks name_remapping + let name = M.findWithDefault name' (varName name') m + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just $ varType name') + (S.singleton context))) + span + []] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') -> do + m <- asks name_remapping + let name = case M.lookup name' m of + Just var -> varName var + Nothing -> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +-- | Dummy instances - never called +instance ToHie (TScoped (LHsSigWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped (LHsWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (SigContext (LSig GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped Type) where + toHie _ = pure [] + +instance HasType (LHsBind GhcRn) where + getTypeNode (L spn bind) = makeNode bind spn + +instance HasType (LHsBind GhcTc) where + getTypeNode (L spn bind) = case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HasType (LPat GhcRn) where + getTypeNode (dL -> L spn pat) = makeNode pat spn + +instance HasType (LPat GhcTc) where + getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) + +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = lift $ + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + _ | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr a -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + HsWrap{} -> False + _ -> True + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a (LHsExpr a)) + , ToHie (LHsExpr a) + , ToHie (Located (PatSynBind a a)) + , HasType (LHsBind a) + , ModifyState (IdP a) + , Data (HsBind a) + ) => ToHie (BindContext (LHsBind a)) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{abs_exports = xs, abs_binds = binds} -> + [ local (modifyState xs) $ -- Note [Name Remapping] + toHie $ fmap (BC context scope) binds + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + XHsBindsLR _ -> [] + +instance ( ToHie (LMatch a body) + ) => ToHie (MatchGroup a body) where + toHie mg = concatM $ case mg of + MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> + [ pure $ locOnly span + , toHie alts + ] + MG{} -> [] + XMatchGroup _ -> [] + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (HsPatSynDir a) + ) => ToHie (Located (PatSynBind a a)) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope NoScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + XPatSynBind _ -> [] + +instance ( ToHie (MatchGroup a (LHsExpr a)) + ) => ToHie (HsPatSynDir a) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( a ~ GhcPass p + , ToHie body + , ToHie (HsMatchContext (NameOrRdrName (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a body) + , Data (Match a body) + ) => ToHie (LMatch (GhcPass p) body) where + toHie (L span m ) = concatM $ makeNode m span : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + XMatch _ -> [] + +instance ( ToHie (Context (Located a)) + ) => ToHie (HsMatchContext a) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( ToHie (HsMatchContext a) + ) => ToHie (HsStmtContext a) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) + , ToHie (LHsExpr a) + , ToHie (TScoped (LHsSigWcType a)) + , ProtectSig a + , ToHie (TScoped (ProtectedSig a)) + , HasType (LPat a) + , Data (HsSplice a) + ) => ToHie (PScoped (LPat (GhcPass p))) where + toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope (dL pat)) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPatIn c dets -> + [ toHie $ C Use c + , toHie $ contextify dets + ] + ConPatOut {pat_con = con, pat_args = dets}-> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , let cscope = mkLScope (dL pat) in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + (protectSig @a cscope sig) + -- See Note [Scoping Rules for SigPat] + ] + CoPat _ _ _ _ -> + [] + XPat _ -> [] + where + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + +instance ( ToHie body + , ToHie (LGRHS a body) + , ToHie (RScoped (LHsLocalBinds a)) + ) => ToHie (GRHSs a body) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + XGRHSs _ -> [] + +instance ( ToHie (Located body) + , ToHie (RScoped (GuardLStmt a)) + , Data (GRHS a (Located body)) + ) => ToHie (LGRHS a (Located body)) where + toHie (L span g) = concatM $ makeNode g span : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + XGRHS _ -> [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , HasType (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (LGRHS a (LHsExpr a)) + , ToHie (RContext (HsRecordBinds a)) + , ToHie (RFContext (Located (AmbiguousFieldOcc a))) + , ToHie (ArithSeqInfo a) + , ToHie (LHsCmdTop a) + , ToHie (RScoped (GuardLStmt a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (TScoped (LHsWcType (NoGhcTc a))) + , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) + , Data (HsExpr a) + , Data (HsSplice a) + , Data (HsTupArg a) + , Data (AmbiguousFieldOcc a) + ) => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_con_name = name, rcon_flds = binds}-> + [ toHie $ C Use name + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsSCC _ _ _ expr -> + [ toHie expr + ] + HsCoreAnn _ _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsArrForm _ expr _ cmds -> + [ toHie expr + , toHie cmds + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsTickPragma _ _ _ _ expr -> + [ toHie expr + ] + HsWrap _ _ a -> + [ toHie $ L mspan a + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + EWildPat _ -> [] + EAsPat _ a b -> + [ toHie $ C Use a + , toHie b + ] + EViewPat _ a b -> + [ toHie a + , toHie b + ] + ELazyPat _ a -> + [ toHie a + ] + XExpr _ -> [] + +instance ( a ~ GhcPass p + , ToHie (LHsExpr a) + , Data (HsTupArg a) + ) => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + XTupArg _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (RScoped (ApplicativeArg a)) + , ToHie (Located body) + , Data (StmtLR a a (Located body)) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body _ _ -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + XStmtLR _ -> [] + +instance ( ToHie (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (LHsLocalBinds a)) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ _ -> [] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + XHsLocalBindsLR _ -> [] + +instance ( ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (XXValBindsLR a a)) + ) => ToHie (RScoped (HsValBindsLR a a)) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance ToHie (RScoped (NHsValBindsLR GhcTc)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] +instance ToHie (RScoped (NHsValBindsLR GhcRn)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie (RContext (LHsRecField a arg)) + ) => ToHie (RContext (HsRecFields a arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg + , HasLoc arg + , Data label + , Data arg + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +removeDefSrcSpan :: Name -> Name +removeDefSrcSpan n = setNameLoc n noSrcSpan + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name + ] + Ambiguous _name _ -> + [ ] + XAmbiguousFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + Ambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XAmbiguousFieldOcc _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (StmtLR a a (Located (HsExpr a))) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + toHie (RS _ (XApplicativeArg _)) = pure [] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance ( ToHie (LHsCmd a) + , Data (HsCmdTop a) + ) => ToHie (LHsCmdTop a) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + XCmdTop _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (MatchGroup a (LHsCmd a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsCmd a) + , Data (HsCmdTop a) + , Data (StmtLR a a (Located (HsCmd a))) + , Data (HsLocalBinds a) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + HsCmdWrap _ _ _ -> [] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie (TyClGroup _ classes roles instances) = concatM + [ toHie classes + , toHie roles + , toHie instances + ] + toHie (XTyClGroup _) = pure [] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (pure . locOnly . getLoc) deftyps + , toHie $ map (go . unLoc) deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + + go :: TyFamDefltEqn GhcRn + -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn) + go (FamEqn a var bndrs pat b rhs) = + FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs + go (XFamEqn NoExt) = XFamEqn NoExt + XTyClDecl _ -> [] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + XFamilyDecl _ -> [] + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (pure . locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + XFamilyResultSig _ -> [] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn pats rhs)) where + toHie (TS _ f) = toHie f + +instance ( ToHie pats + , ToHie rhs + , HasLoc pats + , HasLoc rhs + ) => ToHie (FamEqn GhcRn pats rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + toHie (XFamEqn _) = pure [] + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + toHie (XHsDataDefn _) = pure [] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ pure $ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , pure $ locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + XHsDerivingClause _ -> [] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = pure $ locOnly span + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = qvars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + XConDecl _ -> [] + where condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs + InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ pure $ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsImplicitBndrs _)) = pure [] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsWildCardBndrs _)) = pure [] + +instance ToHie (SigContext (LSig GhcRn)) where + toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , pure $ maybe [] (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ pure $ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + XSig _ -> [] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ bndrs body -> + [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ a b -> + [ toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = pure $ locOnly sp + +instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + XTyVarBndr _ -> [] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $ + [ pure $ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + toHie (TS _ (XLHsQTyVars _)) = pure [] + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ pure $ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + XConDeclField _ -> [] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + XSpliceDecl _ -> [] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance ( ToHie (LHsExpr a) + , Data (HsSplice a) + ) => ToHie (Located (HsSplice a)) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ pure $ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + HsSplicedT _ -> + [] + XSplice _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (pure . locOnly . getLoc) roles + ] + XRoleAnnotDecl _ -> [] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + XInstDecl _ -> [] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + XDerivDecl _ -> [] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + XFixitySig _ -> [] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + XDefaultDecl _ -> [] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + XForeignDecl _ -> [] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = pure $ concat $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + XWarnDecls _ -> [] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + XWarnDecl _ -> [] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + XAnnDecl _ -> [] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + XRuleDecls _ -> [] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L _ (XRuleDecl _)) = pure [] + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , pure $ locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + XRuleBndr _ -> [] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + XImportDecl _ -> [] + where + goIE (hiding, (L sp liens)) = concatM $ + [ pure $ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + XIE _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] + diff --git a/src/Development/IDE/Compat.hs b/src/Development/IDE/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Compat.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Compat + ( + getProcessID + ) where + +#ifdef mingw32_HOST_OS + +import qualified System.Win32.Process as P (getCurrentProcessId) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getCurrentProcessId + +#else + +import qualified System.Posix.Process as P (getProcessID) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getProcessID + +#endif diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -9,6 +9,7 @@ -- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. module Development.IDE.Core.Compile ( TcModuleResult(..) + , RunSimplifier(..) , compileModule , parseModule , typecheckModule @@ -16,6 +17,13 @@ , addRelativeImport , mkTcModuleResult , generateByteCode + , generateAndWriteHieFile + , generateAndWriteHiFile + , getModSummaryFromImports + , loadHieFile + , loadInterface + , loadDepModule + , loadModuleHome ) where import Development.IDE.Core.RuleTypes @@ -29,6 +37,7 @@ import qualified GHC.LanguageExtensions.Type as GHC import Development.IDE.Types.Options import Development.IDE.Types.Location +import Outputable #if MIN_GHC_API_VERSION(8,6,0) import DynamicLoading (initializePlugins) @@ -37,43 +46,59 @@ import GHC hiding (parseModule, typecheckModule) import qualified Parser import Lexer +#if MIN_GHC_API_VERSION(8,10,0) +#else import ErrUtils +#endif -import qualified GHC +import Finder +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat as Compat import GhcMonad import GhcPlugins as GHC hiding (fst3, (<>)) import qualified HeaderInfo as Hdr -import HscMain (hscInteractive) +import HscMain (hscInteractive, hscSimplify) +import LoadIface (readIface) +import qualified Maybes import MkIface +import NameCache import StringBuffer as SB +import TcRnMonad (initIfaceLoad, tcg_th_coreplugins) +import TcIface (typecheckIface) import TidyPgm +import Control.Exception.Safe import Control.Monad.Extra import Control.Monad.Except import Control.Monad.Trans.Except -import Data.Function -import Data.Ord +import Data.Bifunctor (first, second) import qualified Data.Text as T import Data.IORef import Data.List.Extra import Data.Maybe -import Data.Tuple.Extra import qualified Data.Map.Strict as Map import System.FilePath +import System.Directory +import System.IO.Extra +import Data.Either.Extra (maybeToEither) +import Control.DeepSeq (rnf) +import Control.Exception (evaluate) +import Exception (ExceptionMonad) -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule :: IdeOptions -> HscEnv + -> [PackageName] -> FilePath -> Maybe SB.StringBuffer -> IO (IdeResult (StringBuffer, ParsedModule)) -parseModule IdeOptions{..} env filename mbContents = +parseModule IdeOptions{..} env comp_pkgs filename mbContents = fmap (either (, Nothing) id) $ - runGhcEnv env $ runExceptT $ do + evalGhcEnv env $ runExceptT $ do (contents, dflags) <- preprocessor filename mbContents - (diag, modu) <- parseFileContents optPreprocessor dflags filename contents + (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents return (diag, Just (contents, modu)) @@ -85,35 +110,40 @@ computePackageDeps env pkg = do let dflags = hsc_dflags env case lookupInstalledPackage dflags pkg of - Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $ + Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ depends pkgInfo +typecheckModule :: IdeDefer + -> HscEnv + -> [(ModSummary, (ModIface, Maybe Linkable))] + -> ParsedModule + -> IO (IdeResult (HscEnv, TcModuleResult)) +typecheckModule (IdeDefer defer) hsc depsIn pm = do + fmap (either (, Nothing) (second Just . sequence) . sequence) $ + runGhcEnv hsc $ + catchSrcErrors "typecheck" $ do + -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. + -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. + -- Long-term we might just want to change the order returned by GetDependencies + let deps = reverse depsIn --- | Typecheck a single module using the supplied dependencies and packages. -typecheckModule - :: IdeDefer - -> HscEnv - -> [TcModuleResult] - -> ParsedModule - -> IO (IdeResult TcModuleResult) -typecheckModule (IdeDefer defer) packageState deps pm = - let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id - in - fmap (either (, Nothing) (second Just)) $ - runGhcEnv packageState $ - catchSrcErrors "typecheck" $ do - setupEnv deps - let modSummary = pm_mod_summary pm - dflags = ms_hspp_opts modSummary - modSummary' <- initPlugins modSummary - (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - GHC.typecheckModule $ enableTopLevelWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} - tcm2 <- mkTcModuleResult tcm - let errorPipeline = unDefer . hideDiag dflags - return (map errorPipeline warnings, tcm2) + setupFinderCache (map fst deps) + let modSummary = pm_mod_summary pm + dflags = ms_hspp_opts modSummary + + mapM_ (uncurry loadDepModule . snd) deps + modSummary' <- initPlugins modSummary + (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> + GHC.typecheckModule $ enableTopLevelWarnings + $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + tcm2 <- mkTcModuleResult tcm + let errorPipeline = unDefer . hideDiag dflags + return (map errorPipeline warnings, tcm2) + where + demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id + initPlugins :: GhcMonad m => ModSummary -> m ModSummary initPlugins modSummary = do #if MIN_GHC_API_VERSION(8,6,0) @@ -124,18 +154,25 @@ return modSummary #endif +-- | Whether we should run the -O0 simplifier when generating core. +-- +-- This is required for template Haskell to work but we disable this in DAML. +-- See #256 +newtype RunSimplifier = RunSimplifier Bool + -- | Compile a single type-checked module to a 'CoreModule' value, or -- provide errors. compileModule - :: HscEnv - -> [TcModuleResult] + :: RunSimplifier + -> HscEnv + -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) -compileModule packageState deps tmr = +compileModule (RunSimplifier simplify) packageState deps tmr = fmap (either (, Nothing) (second Just)) $ - runGhcEnv packageState $ + evalGhcEnv packageState $ catchSrcErrors "compile" $ do - setupEnv (deps ++ [tmr]) + setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)]) let tm = tmrModule tmr session <- getSession @@ -144,20 +181,30 @@ let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm} let tm' = tm{tm_parsed_module = pm'} GHC.dm_core_module <$> GHC.desugarModule tm' - + let tc_result = fst (tm_internals_ (tmrModule tmr)) + desugared_guts <- + if simplify + then do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + liftIO $ hscSimplify session plugins desugar + else pure desugar -- give variables unique OccNames - (guts, details) <- liftIO $ tidyProgram session desugar + (guts, details) <- liftIO $ tidyProgram session desugared_guts return (map snd warnings, (mg_safe_haskell desugar, guts, details)) -generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable) +generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable) generateByteCode hscEnv deps tmr guts = fmap (either (, Nothing) (second Just)) $ - runGhcEnv hscEnv $ + evalGhcEnv hscEnv $ catchSrcErrors "bytecode" $ do - setupEnv (deps ++ [tmr]) + setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)]) session <- getSession (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak -> - liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr) +#if MIN_GHC_API_VERSION(8,10,0) + liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr) +#else + liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr) +#endif let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr let unlinked = BCOs bytecode sptEntries let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked] @@ -179,9 +226,10 @@ enableTopLevelWarnings :: ParsedModule -> ParsedModule enableTopLevelWarnings = (update_pm_mod_summary . update_hspp_opts) - (`wopt_set` Opt_WarnMissingSignatures) + ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) . + (`wopt_set` Opt_WarnMissingSignatures)) -- the line below would show also warnings for let bindings without signature - -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)) + -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))) update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} @@ -205,9 +253,9 @@ hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) hideDiag originalFlags (Reason warning, (nfp, _sh, fd)) | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd)) -hideDiag _originalFlags t = t +hideDiag _originalFlags t = t -addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags +addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags addRelativeImport fp modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} @@ -217,25 +265,81 @@ -> m TcModuleResult mkTcModuleResult tcm = do session <- getSession - (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv + let sf = modInfoSafe (tm_checked_module_info tcm) +#if MIN_GHC_API_VERSION(8,10,0) + iface <- liftIO $ mkIfaceTc session sf details tcGblEnv +#else + (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv +#endif let mod_info = HomeModInfo iface details Nothing return $ TcModuleResult tcm mod_info where (tcGblEnv, details) = tm_internals_ tcm +atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO () +atomicFileWrite targetPath write = do + let dir = takeDirectory targetPath + createDirectoryIfMissing True dir + (tempFilePath, cleanUp) <- newTempFileWithin dir + (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp + +generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic] +generateAndWriteHieFile hscEnv tcm = + handleGenerationErrors dflags "extended interface generation" $ do + case tm_renamed_source tcm of + Just rnsrc -> do + hf <- runHsc hscEnv $ + GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc "" + atomicFileWrite targetPath $ flip GHC.writeHieFile hf + _ -> + return () + where + dflags = hsc_dflags hscEnv + mod_summary = pm_mod_summary $ tm_parsed_module tcm + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + +generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic] +generateAndWriteHiFile hscEnv tc = + handleGenerationErrors dflags "interface generation" $ do + atomicFileWrite targetPath $ \fp -> + writeIfaceFile dflags fp modIface + where + modIface = hm_iface $ tmrModInfo tc + modSummary = tmrModSummary tc + targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc + withBootSuffix = case ms_hsc_src modSummary of + HsBootFile -> addBootSuffix + _ -> id + dflags = hsc_dflags hscEnv + +handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] +handleGenerationErrors dflags source action = + action >> return [] `catches` + [ Handler $ return . diagFromGhcException source dflags + , Handler $ return . diagFromString source DsError (noSpan "") + . (("Error during " ++ T.unpack source) ++) . show @SomeException + ] + + -- | Setup the environment that GHC needs according to our -- best understanding (!) -setupEnv :: GhcMonad m => [TcModuleResult] -> m () -setupEnv tmsIn = do - -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file - -- takes precedence, so put the .hs-boot file earlier in the list - let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule - tms = sortBy (compare `on` Down . isSourceFile) tmsIn +-- +-- This involves setting up the finder cache and populating the +-- HPT. +setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m () +setupEnv tms = do + setupFinderCache (map fst tms) + -- load dependent modules, which must be in topological order. + modifySession $ \e -> + foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms +-- | Initialise the finder cache, dependencies should be topologically +-- sorted. +setupFinderCache :: GhcMonad m => [ModSummary] -> m () +setupFinderCache mss = do session <- getSession - let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms - -- set the target and module graph in the session let graph = mkModuleGraph mss setSession session { hsc_mod_graph = graph } @@ -254,26 +358,40 @@ newFinderCacheVar <- liftIO $ newIORef $! newFinderCache modifySession $ \s -> s { hsc_FC = newFinderCacheVar } - -- load dependent modules, which must be in topological order. - mapM_ loadModuleHome tms - -- | Load a module, quickly. Input doesn't need to be desugared. -- A module must be loaded before dependent modules can be typechecked. -- This variant of loadModuleHome will *never* cause recompilation, it just -- modifies the session. +-- +-- The order modules are loaded is important when there are hs-boot files. +-- In particular you should make sure to load the .hs version of a file after the +-- .hs-boot version. loadModuleHome - :: (GhcMonad m) - => TcModuleResult - -> m () -loadModuleHome tmr = modifySession $ \e -> - e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info } - where - ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr - mod_info = tmrModInfo tmr - mod = ms_mod_name ms + :: HomeModInfo + -> HscEnv + -> HscEnv +loadModuleHome mod_info e = + e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info } + where + mod_name = moduleName $ mi_module $ hm_iface mod_info +-- | Load module interface. +loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv +loadDepModuleIO iface linkable hsc = do + details <- liftIO $ fixIO $ \details -> do + let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) } + initIfaceLoad hsc' (typecheckIface iface) + let mod_info = HomeModInfo iface details linkable + return $ loadModuleHome mod_info hsc + where + mod = moduleName $ mi_module iface +loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m () +loadDepModule iface linkable = do + e <- getSession + e' <- liftIO $ loadDepModuleIO iface linkable e + setSession e' -- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's -- name and its imports. @@ -294,30 +412,18 @@ , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim" ]) - -- | Produce a module summary from a StringBuffer. getModSummaryFromBuffer :: GhcMonad m => FilePath - -> SB.StringBuffer -> DynFlags -> GHC.ParsedSource -> ExceptT [FileDiagnostic] m ModSummary -getModSummaryFromBuffer fp contents dflags parsed = do +getModSummaryFromBuffer fp dflags parsed = do (modName, imports) <- liftEither $ getImportsParsed dflags parsed - let modLoc = ModLocation - { ml_hs_file = Just fp - , ml_hi_file = derivedFile "hi" - , ml_obj_file = derivedFile "o" -#if MIN_GHC_API_VERSION(8,8,0) - , ml_hie_file = derivedFile "hie" -#endif - -- This does not consider the dflags configuration - -- (-osuf and -hisuf, object and hi dir.s). - -- However, we anyway don't want to generate them. - } - InstalledUnitId unitId = thisInstalledUnitId dflags + modLoc <- liftIO $ mkHomeModLocation dflags modName fp + let InstalledUnitId unitId = thisInstalledUnitId dflags return $ ModSummary { ms_mod = mkModule (fsToUnitId unitId) modName , ms_location = modLoc @@ -329,7 +435,7 @@ , ms_textual_imps = [imp | (False, imp) <- imports] , ms_hspp_file = fp , ms_hspp_opts = dflags - , ms_hspp_buf = Just contents + , ms_hspp_buf = Nothing -- defaults: , ms_hsc_src = sourceType @@ -342,27 +448,71 @@ , ms_parsed_mod = Nothing } where - (sourceType, derivedFile) = - let (stem, ext) = splitExtension fp in - if "-boot" `isSuffixOf` ext - then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot") - else (HsSrcFile , \newExt -> stem <.> newExt) + sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile +-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. +-- Runs preprocessors as needed. +getModSummaryFromImports + :: (HasDynFlags m, ExceptionMonad m, MonadIO m) + => FilePath + -> Maybe SB.StringBuffer + -> ExceptT [FileDiagnostic] m ModSummary +getModSummaryFromImports fp contents = do + (contents, dflags) <- preprocessor fp contents + (srcImports, textualImports, L _ moduleName) <- + ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp --- | Given a buffer, flags, file path and module summary, produce a + -- Force bits that might keep the string buffer and DynFlags alive unnecessarily + liftIO $ evaluate $ rnf srcImports + liftIO $ evaluate $ rnf textualImports + + modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp + + let mod = mkModule (thisPackage dflags) moduleName + sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile + summary = + ModSummary + { ms_mod = mod +#if MIN_GHC_API_VERSION(8,8,0) + , ms_hie_date = Nothing +#endif + , ms_hs_date = error "Rules should not depend on ms_hs_date" + -- When we are working with a virtual file we do not have a file date. + -- To avoid silent issues where something is not processed because the date + -- has not changed, we make sure that things blow up if they depend on the date. + , ms_hsc_src = sourceType + , ms_hspp_buf = Nothing + , ms_hspp_file = fp + , ms_hspp_opts = dflags + , ms_iface_date = Nothing + , ms_location = modLoc + , ms_obj_date = Nothing + , ms_parsed_mod = Nothing + , ms_srcimps = srcImports + , ms_textual_imps = textualImports + } + return summary + + +-- | Given a buffer, flags, and file path, produce a -- parsed module (or errors) and any parse warnings. Does not run any preprocessors parseFileContents :: GhcMonad m => (GHC.ParsedSource -> IdePreprocessedSource) -> DynFlags -- ^ flags to use + -> [PackageName] -- ^ The package imports to ignore -> FilePath -- ^ the filename (for source locations) -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule) -parseFileContents customPreprocessor dflags filename contents = do +parseFileContents customPreprocessor dflags comp_pkgs filename contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseModule (mkPState dflags contents loc) of +#if MIN_GHC_API_VERSION(8,10,0) + PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags +#else PFailed _ locErr msgErr -> throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr +#endif POk pst rdr_module -> let hpm_annotations = (Map.fromListWith (++) $ annotations pst, @@ -386,14 +536,63 @@ -- Ok, we got here. It's safe to continue. let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs + let parsed' = removePackageImports comp_pkgs parsed let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - ms <- getModSummaryFromBuffer filename contents dflags parsed + ms <- getModSummaryFromBuffer filename dflags parsed' let pm = ParsedModule { pm_mod_summary = ms - , pm_parsed_source = parsed + , pm_parsed_source = parsed' , pm_extra_src_files=[] -- src imports not allowed , pm_annotations = hpm_annotations } warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) + + +-- | After parsing the module remove all package imports referring to +-- these packages as we have already dealt with what they map to. +removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource +removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' }) + where + imports' = map do_one_import hsmodImports + do_one_import (L l i@ImportDecl{ideclPkgQual}) = + case PackageName . sl_fs <$> ideclPkgQual of + Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing }) + _ -> L l i +#if MIN_GHC_API_VERSION(8,6,0) + do_one_import l = l +#endif + +loadHieFile :: FilePath -> IO GHC.HieFile +loadHieFile f = do + u <- mkSplitUniqSupply 'a' + let nameCache = initNameCache u [] + fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f + +-- | Retuns an up-to-date module interface if available. +-- Assumes file exists. +-- Requires the 'HscEnv' to be set up with dependencies +loadInterface + :: HscEnv + -> ModSummary + -> [HiFileResult] + -> IO (Either String ModIface) +loadInterface session ms deps = do + let hiFile = case ms_hsc_src ms of + HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) + _ -> ml_hi_file $ ms_location ms + r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile + case r of + Maybes.Succeeded iface -> do + session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps + (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface) + return $ maybeToEither (showReason reason) iface' + Maybes.Failed err -> do + let errMsg = showSDoc (hsc_dflags session) err + return $ Left errMsg + +showReason :: RecompileRequired -> String +showReason MustCompile = "Stale" +showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")" +showReason UpToDate = "Up to date" diff --git a/src/Development/IDE/Core/Debouncer.hs b/src/Development/IDE/Core/Debouncer.hs --- a/src/Development/IDE/Core/Debouncer.hs +++ b/src/Development/IDE/Core/Debouncer.hs @@ -3,8 +3,9 @@ module Development.IDE.Core.Debouncer ( Debouncer - , newDebouncer , registerEvent + , newAsyncDebouncer + , noopDebouncer ) where import Control.Concurrent.Extra @@ -22,13 +23,14 @@ -- by delaying each event for a given time. If another event -- is registered for the same key within that timeframe, -- only the new event will fire. -newtype Debouncer k = Debouncer (Var (HashMap k (Async ()))) +-- +-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable +-- debouncing in the DAML CLI compiler. +newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () } --- | Create a new empty debouncer. -newDebouncer :: IO (Debouncer k) -newDebouncer = do - m <- newVar Map.empty - pure $ Debouncer m +-- | Debouncer used in the IDE that delays events as expected. +newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k) +newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty -- | Register an event that will fire after the given delay if no other event -- for the same key gets registered until then. @@ -36,11 +38,15 @@ -- If there is a pending event for the same key, the pending event will be killed. -- Events are run unmasked so it is up to the user of `registerEvent` -- to mask if required. -registerEvent :: (Eq k, Hashable k) => Debouncer k -> Seconds -> k -> IO () -> IO () -registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do +asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () +asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do whenJust (Map.lookup k m) cancel a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire modifyVar_ d (pure . Map.delete k) pure $ Map.insert k a m + +-- | Debouncer used in the DAML CLI compiler that emits events immediately. +noopDebouncer :: Debouncer k +noopDebouncer = Debouncer $ \_ _ a -> a diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -14,13 +14,15 @@ import qualified Data.Aeson as A import Data.Binary import qualified Data.ByteString as BS -import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.FileStore +import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake import Development.IDE.Types.Location +import Development.IDE.Types.Logger import Development.Shake import Development.Shake.Classes import GHC.Generics @@ -30,7 +32,7 @@ import qualified System.Directory as Dir -- | A map for tracking the file existence -type FileExistsMap = (Map NormalizedFilePath Bool) +type FileExistsMap = (HashMap NormalizedFilePath Bool) -- | A wrapper around a mutable 'FileExistsMap' newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap) @@ -53,12 +55,12 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO () modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state - changesMap <- evaluate $ Map.fromList changes + changesMap <- evaluate $ HashMap.fromList changes -- Masked to ensure that the previous values are flushed together with the map update mask $ \_ -> do -- update the map - modifyVar_ var $ evaluate . Map.union changesMap + modifyVar_ var $ evaluate . HashMap.union changesMap -- flush previous values mapM_ (deleteValue state GetFileExists . fst) changes @@ -89,20 +91,34 @@ -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules () -fileExistsRules getLspId ClientCapabilities{_workspace} - | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace - , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles - , Just True <- _dynamicRegistration - = fileExistsRulesFast getLspId - | otherwise = fileExistsRulesSlow +fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do + -- Create the global always, although it should only be used if we have fast rules. + -- But there's a chance someone will send unexpected notifications anyway, + -- e.g. https://github.com/digital-asset/ghcide/issues/599 + addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) + case () of + _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace + , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles + , Just True <- _dynamicRegistration + -> fileExistsRulesFast getLspId vfs + | otherwise -> do + logger <- logger <$> getShakeExtrasRules + liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling" + fileExistsRulesSlow vfs -- Requires an lsp client that provides WatchedFiles notifications. fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules () -fileExistsRulesFast getLspId vfs = do - addIdeGlobal . FileExistsMapVar =<< liftIO (newVar []) +fileExistsRulesFast getLspId vfs = defineEarlyCutoff $ \GetFileExists file -> do + isWf <- isWorkspaceFile file + if isWf + then fileExistsFast getLspId vfs file + else fileExistsSlow vfs file + +fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) +fileExistsFast getLspId vfs file = do fileExistsMap <- getFileExistsMapUntracked - let mbFilesWatched = Map.lookup file fileExistsMap + let mbFilesWatched = HashMap.lookup file fileExistsMap case mbFilesWatched of Just fv -> pure (summarizeExists fv, ([], Just fv)) Nothing -> do @@ -113,7 +129,7 @@ -- taking the FileExistsMap lock to prevent race conditions -- that would lead to multiple listeners for the same path modifyFileExistsAction $ \x -> do - case Map.insertLookupWithKey (\_ x _ -> x) file exist x of + case HashMap.alterF (,Just exist) file x of (Nothing, x') -> do -- if the listener addition fails, we never recover. This is a bug. addListener eventer file @@ -134,9 +150,10 @@ WorkspaceDidChangeWatchedFiles (Just (A.toJSON regOptions)) regOptions = - DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] } - watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp - , kind = Just 5 -- Create and Delete events only + DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] } + watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True} + watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp + , _kind = Just watchKind } eventer $ ReqRegisterCapability req @@ -145,8 +162,11 @@ summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty fileExistsRulesSlow:: VFSHandle -> Rules () -fileExistsRulesSlow vfs = do - defineEarlyCutoff $ \GetFileExists file -> do +fileExistsRulesSlow vfs = + defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file + +fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool)) +fileExistsSlow vfs file = do alwaysRerun exist <- liftIO $ getFileExistsVFS vfs file pure (summarizeExists exist, ([], Just exist)) @@ -159,29 +179,3 @@ handle (\(_ :: IOException) -> return False) $ (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^ Dir.doesFileExist (fromNormalizedFilePath file) - --------------------------------------------------------------------------------------------------- --- The message definitions below probably belong in haskell-lsp-types - -data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions - { watchers :: List FileSystemWatcher - } - -instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where - toJSON DidChangeWatchedFilesRegistrationOptions {..} = - A.object ["watchers" A..= watchers] - -data FileSystemWatcher = FileSystemWatcher - { -- | The glob pattern to watch. - -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles - globPattern :: String - -- | The kind of event to subscribe to. Defaults to all. - -- Defined as a bitmap of Create(1), Change(2), and Delete(4) - , kind :: Maybe Int - } - -instance A.ToJSON FileSystemWatcher where - toJSON FileSystemWatcher {..} = - A.object - $ ["globPattern" A..= globPattern] - ++ [ "kind" A..= x | Just x <- [kind] ] diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -95,11 +95,12 @@ getModificationTimeRule vfs = defineEarlyCutoff $ \GetModificationTime file -> do let file' = fromNormalizedFilePath file - let wrap time = (Just time, ([], Just $ ModificationTime time)) + let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s)) alwaysRerun mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file case mbVirtual of - Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver)) + Just (virtualFileVersion -> ver) -> + pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver)) Nothing -> liftIO $ fmap wrap (getModTime file') `catch` \(e :: IOException) -> do let err | isDoesNotExistError e = "File does not exist: " ++ file' @@ -115,11 +116,13 @@ -- We might also want to try speeding this up on Windows at some point. -- TODO leverage DidChangeWatchedFile lsp notifications on clients that -- support them, as done for GetFileExists - getModTime :: FilePath -> IO BS.ByteString + getModTime :: FilePath -> IO (Int,Int) getModTime f = #ifdef mingw32_HOST_OS do time <- Dir.getModificationTime f - pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time) + let !day = fromInteger $ toModifiedJulianDay $ utctDay time + !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time + pure (day, dayTime) #else withCString f $ \f' -> alloca $ \secPtr -> @@ -127,7 +130,7 @@ Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr sec <- peek secPtr nsec <- peek nsecPtr - pure $! BS.pack $ show sec <> "." <> show nsec + pure (fromEnum sec, fromIntegral nsec) -- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow -- as doing the FFI call ourselves :(. diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module Development.IDE.Core.IdeConfiguration + ( IdeConfiguration(..) + , registerIdeConfiguration + , parseConfiguration + , parseWorkspaceFolder + , isWorkspaceFile + , modifyWorkspaceFolders + ) +where + +import Control.Concurrent.Extra +import Control.Monad +import Data.HashSet (HashSet, singleton) +import Data.Text (Text, isPrefixOf) +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.Shake +import Language.Haskell.LSP.Types +import System.FilePath (isRelative) + +-- | Lsp client relevant configuration details +data IdeConfiguration = IdeConfiguration + { workspaceFolders :: HashSet NormalizedUri + } + deriving (Show) + +newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration} + +instance IsIdeGlobal IdeConfigurationVar + +registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO () +registerIdeConfiguration extras = + addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar + +getIdeConfiguration :: Action IdeConfiguration +getIdeConfiguration = + getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef + +parseConfiguration :: InitializeParams -> IdeConfiguration +parseConfiguration InitializeParams {..} = + IdeConfiguration { .. } + where + workspaceFolders = + foldMap (singleton . toNormalizedUri) _rootUri + <> (foldMap . foldMap) + (singleton . parseWorkspaceFolder) + _workspaceFolders + +parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri +parseWorkspaceFolder = + toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text) + +modifyWorkspaceFolders + :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () +modifyWorkspaceFolders ide f = do + IdeConfigurationVar var <- getIdeGlobalState ide + IdeConfiguration ws <- readVar var + writeVar var (IdeConfiguration (f ws)) + +isWorkspaceFile :: NormalizedFilePath -> Action Bool +isWorkspaceFile file = + if isRelative (fromNormalizedFilePath file) + then return True + else do + IdeConfiguration {..} <- getIdeConfiguration + let toText = getUri . fromNormalizedUri + return $ + any + (\root -> toText root `isPrefixOf` toText (filePathToUri' file)) + workspaceFolders diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -19,8 +19,8 @@ import Data.Typeable import qualified Data.ByteString.UTF8 as BS import Control.Exception -import Data.Set (Set) -import qualified Data.Set as Set +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import qualified Data.Text as T import Data.Tuple.Extra import Data.Functor @@ -31,10 +31,10 @@ import Development.IDE.Core.Shake -newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath)) +newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath)) instance IsIdeGlobal OfInterestVar -type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath +type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath data GetFilesOfInterest = GetFilesOfInterest deriving (Eq, Show, Typeable, Generic) @@ -46,7 +46,7 @@ -- | The rule that initialises the files of interest state. ofInterestRules :: Rules () ofInterestRules = do - addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty) + addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty) defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked @@ -54,7 +54,7 @@ -- | Get the files that are open in the IDE. -getFilesOfInterest :: Action (Set NormalizedFilePath) +getFilesOfInterest :: Action (HashSet NormalizedFilePath) getFilesOfInterest = useNoFile_ GetFilesOfInterest @@ -64,19 +64,19 @@ -- | Set the files-of-interest - not usually necessary or advisable. -- The LSP client will keep this information up to date. -setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO () +setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO () setFilesOfInterest state files = modifyFilesOfInterest state (const files) -getFilesOfInterestUntracked :: Action (Set NormalizedFilePath) +getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath) getFilesOfInterestUntracked = do OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -- | Modify the files-of-interest - not usually necessary or advisable. -- The LSP client will keep this information up to date. -modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO () +modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO () modifyFilesOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar var $ pure . dupe . f - logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files) + logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files) void $ shakeRun state [] diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -2,10 +2,15 @@ -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping ( PositionMapping(..) + , fromCurrentPosition + , toCurrentPosition + , PositionDelta(..) + , addDelta + , mkDelta , toCurrentRange , fromCurrentRange , applyChange - , idMapping + , zeroMapping -- toCurrent and fromCurrent are mainly exposed for testing , toCurrent , fromCurrent @@ -14,12 +19,25 @@ import Control.Monad import qualified Data.Text as T import Language.Haskell.LSP.Types +import Data.List -data PositionMapping = PositionMapping - { toCurrentPosition :: !(Position -> Maybe Position) - , fromCurrentPosition :: !(Position -> Maybe Position) +-- The position delta is the difference between two versions +data PositionDelta = PositionDelta + { toDelta :: !(Position -> Maybe Position) + , fromDelta :: !(Position -> Maybe Position) } +fromCurrentPosition :: PositionMapping -> Position -> Maybe Position +fromCurrentPosition (PositionMapping pm) = fromDelta pm + +toCurrentPosition :: PositionMapping -> Position -> Maybe Position +toCurrentPosition (PositionMapping pm) = toDelta pm + +-- A position mapping is the difference from the current version to +-- a specific version +newtype PositionMapping = PositionMapping PositionDelta + + toCurrentRange :: PositionMapping -> Range -> Maybe Range toCurrentRange mapping (Range a b) = Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b @@ -28,13 +46,33 @@ fromCurrentRange mapping (Range a b) = Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b -idMapping :: PositionMapping -idMapping = PositionMapping Just Just +zeroMapping :: PositionMapping +zeroMapping = PositionMapping idDelta -applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping -applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping - { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping - , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t +-- | Compose two position mappings. Composes in the same way as function +-- composition (ie the second argument is applyed to the position first). +composeDelta :: PositionDelta + -> PositionDelta + -> PositionDelta +composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) = + PositionDelta (to1 <=< to2) + (from1 >=> from2) + +idDelta :: PositionDelta +idDelta = PositionDelta Just Just + +-- | Convert a set of changes into a delta from k to k + 1 +mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta +mkDelta cs = foldl' applyChange idDelta cs + +-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n +addDelta :: PositionDelta -> PositionMapping -> PositionMapping +addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) + +applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta + { toDelta = toCurrent r t <=< toDelta + , fromDelta = fromDelta <=< fromCurrent r t } applyChange posMapping _ = posMapping diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -29,11 +29,15 @@ import Data.Text (Text) import qualified Data.Text as T import Outputable (showSDoc) +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (evaluate) +import Control.Monad.IO.Class (MonadIO) +import Exception (ExceptionMonad) -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags) +preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags) preprocessor filename mbContents = do -- Perform unlit (isOnDisk, contents) <- @@ -96,7 +100,7 @@ diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $ + map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and @@ -118,7 +122,8 @@ _code = Nothing, _source = Just "CPP", _message = T.unlines $ cdMessage d, - _relatedInformation = Nothing + _relatedInformation = Nothing, + _tags = Nothing } @@ -128,13 +133,17 @@ -- | This reads the pragma information directly from the provided buffer. parsePragmasIntoDynFlags - :: GhcMonad m + :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> SB.StringBuffer -> m (Either [FileDiagnostic] DynFlags) parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do - dflags0 <- getSessionDynFlags + dflags0 <- getDynFlags let opts = Hdr.getOptions dflags0 contents fp + + -- Force bits that might keep the dflags and stringBuffer alive unnecessarily + liftIO $ evaluate $ rnf opts + (dflags, _, _) <- parseDynamicFilePragma dflags0 opts return dflags @@ -166,18 +175,11 @@ escape (c:cs) = c : escape cs escape [] = [] - -modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags -modifyOptP op = onSettings (onOptP op) - where - onSettings f x = x{settings = f $ settings x} - onOptP f x = x{sOpt_P = f $ sOpt_P x} - -- | Run CPP on a file runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer runCpp dflags filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - dflags <- pure $ modifyOptP ("-D__GHCIDE__":) dflags + dflags <- pure $ addOptP "-D__GHCIDE__" dflags case contents of Nothing -> do diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -15,7 +15,6 @@ import Data.Binary import Development.IDE.Import.DependencyInformation import Development.IDE.GHC.Util -import Development.IDE.Types.Location import Data.Hashable import Data.Typeable import qualified Data.Set as S @@ -25,9 +24,9 @@ import GHC import Module (InstalledUnitId) import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails) -import Development.IDE.GHC.Compat import Development.IDE.Spans.Type +import Development.IDE.Import.FindImports (ArtifactsLocation) -- NOTATION @@ -58,6 +57,22 @@ instance NFData TcModuleResult where rnf = rwhnf +tmrModSummary :: TcModuleResult -> ModSummary +tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule + +data HiFileResult = HiFileResult + { hirModSummary :: !ModSummary + -- Bang patterns here are important to stop the result retaining + -- a reference to a typechecked module + , hirModIface :: !ModIface + } + +instance NFData HiFileResult where + rnf = rwhnf + +instance Show HiFileResult where + show = show . hirModSummary + -- | The type checked version of this file, requires TypeCheck+ type instance RuleResult TypeCheck = TcModuleResult @@ -75,17 +90,25 @@ -- | Resolve the imports in a module to the file path of a module -- in the same package or the package id of another package. -type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId) +type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId) -- | This rule is used to report import cycles. It depends on GetDependencyInformation. -- We cannot report the cycles directly from GetDependencyInformation since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () --- | Read the given HIE file. -type instance RuleResult GetHieFile = HieFile +-- | Read the module interface file +type instance RuleResult GetHiFile = HiFileResult +-- | Get a module interface, either from an interface file or a typechecked module +type instance RuleResult GetModIface = HiFileResult +type instance RuleResult IsFileOfInterest = Bool + +-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files. +-- without needing to parse the entire source +type instance RuleResult GetModSummary = ModSummary + data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule @@ -146,10 +169,26 @@ instance NFData GhcSession instance Binary GhcSession --- Note that we embed the filepath here instead of using the filepath associated with Shake keys. --- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable. -data GetHieFile = GetHieFile FilePath +data GetHiFile = GetHiFile deriving (Eq, Show, Typeable, Generic) -instance Hashable GetHieFile -instance NFData GetHieFile -instance Binary GetHieFile +instance Hashable GetHiFile +instance NFData GetHiFile +instance Binary GetHiFile + +data GetModIface = GetModIface + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModIface +instance NFData GetModIface +instance Binary GetModIface + +data IsFileOfInterest = IsFileOfInterest + deriving (Eq, Show, Typeable, Generic) +instance Hashable IsFileOfInterest +instance NFData IsFileOfInterest +instance Binary IsFileOfInterest + +data GetModSummary = GetModSummary + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetModSummary +instance NFData GetModSummary +instance Binary GetModSummary diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -1,16 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DuplicateRecordFields #-} +#include "ghc-api-version.h" -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. -- module Development.IDE.Core.Rules( IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..), - Priority(..), + Priority(..), GhcSessionIO(..), GhcSessionFun(..), priorityTypeCheck, priorityGenerateCore, priorityFilesOfInterest, @@ -26,11 +28,13 @@ import Fingerprint -import Data.Binary -import Control.Monad +import Data.Binary hiding (get, put) +import Data.Bifunctor (first, second) +import Control.Monad.Extra import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Development.IDE.Core.Compile +import Development.IDE.Core.OfInterest import Development.IDE.Types.Options import Development.IDE.Spans.Calculate import Development.IDE.Import.DependencyInformation @@ -39,35 +43,40 @@ import Development.IDE.Core.FileStore (getFileContents) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule) import Development.IDE.GHC.Util -import Data.Coerce +import Development.IDE.GHC.WithDynFlags import Data.Either.Extra import Data.Maybe import Data.Foldable import qualified Data.IntMap.Strict as IntMap -import qualified Data.IntSet as IntSet +import Data.IntMap.Strict (IntMap) import Data.List +import Data.Ord import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE.GHC.Error import Development.Shake hiding (Diagnostic) import Development.IDE.Core.RuleTypes import Development.IDE.Spans.Type +import qualified Data.ByteString.Char8 as BS -import GHC hiding (parseModule, typecheckModule) import qualified GHC.LanguageExtensions as LangExt -import Development.IDE.GHC.Compat (hie_file_result, readHieFile) -import UniqSupply -import NameCache import HscTypes -import DynFlags (xopt) +import PackageConfig +import DynFlags (gopt_set, xopt) import GHC.Generics(Generic) import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.Shake.Classes +import Development.Shake.Classes hiding (get, put) +import Control.Monad.Trans.Except (runExceptT) +import Data.ByteString (ByteString) +import Control.Concurrent.Async (concurrently) +import Control.Monad.State + -- | 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. @@ -80,14 +89,14 @@ useE k = MaybeT . use k useNoFileE :: IdeRule k v => k -> MaybeT Action v -useNoFileE k = useE k "" +useNoFileE k = useE k emptyFilePath usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v] usesE k = MaybeT . fmap sequence . uses k defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = define $ \k file -> do - if file == "" then do res <- f k; return ([], Just res) else + 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" @@ -111,10 +120,59 @@ getDefinition file pos = fmap join $ runMaybeT $ do opts <- lift getIdeOptions spans <- useE GetSpanInfo file - pkgState <- hscEnv <$> useE GhcSession file - let getHieFile x = useNoFile (GetHieFile x) - lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos + lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos +getHieFile + :: NormalizedFilePath -- ^ file we're editing + -> Module -- ^ module dep we want info for + -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module +getHieFile file mod = do + TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file + case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of + Just NamedModuleDep{nmdFilePath=nfp} -> do + let modPath = fromNormalizedFilePath nfp + (_diags, hieFile) <- getHomeHieFile nfp + return $ (, modPath) <$> hieFile + _ -> getPackageHieFile mod file + + +getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile) +getHomeHieFile f = do + ms <- use_ GetModSummary f + let normal_hie_f = toNormalizedFilePath' hie_f + hie_f = ml_hie_file $ ms_location ms + mbHieTimestamp <- use GetModificationTime normal_hie_f + srcTimestamp <- use_ GetModificationTime f + let isUpToDate + | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT + | otherwise = False + + unless isUpToDate $ + void $ use_ TypeCheck f + + hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f) + return ([], hf) + +getPackageHieFile :: Module -- ^ Package Module to load .hie file for + -> NormalizedFilePath -- ^ Path of home module importing the package module + -> Action (Maybe (HieFile, FilePath)) +getPackageHieFile mod file = do + pkgState <- hscEnv <$> use_ GhcSession file + IdeOptions {..} <- getIdeOptions + 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) -> + -- deliberately loaded outside the Shake graph + -- to avoid dependencies on non-workspace files + liftIO $ Just . (, modPath) <$> loadHieFile hiePath + _ -> return Nothing + _ -> return Nothing + -- | Parse the contents of a daml file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) getParsedModule file = use GetParsedModule file @@ -133,31 +191,60 @@ priorityFilesOfInterest = Priority (-2) getParsedModuleRule :: Rules () -getParsedModuleRule = - defineEarlyCutoff $ \GetParsedModule file -> do - (_, contents) <- getFileContents file - packageState <- hscEnv <$> use_ GhcSession file - opt <- getIdeOptions - (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents) - case res of - Nothing -> pure (Nothing, (diag, Nothing)) - Just (contents, modu) -> do - mbFingerprint <- if isNothing $ optShakeFiles opt - then pure Nothing - else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents - pure (mbFingerprint, (diag, Just modu)) +getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do + sess <- use_ GhcSession file + let hsc = hscEnv sess + -- These packages are used when removing PackageImports from a + -- parsed module + comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) + opt <- getIdeOptions + (_, contents) <- getFileContents file + let dflags = hsc_dflags hsc + mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents + + -- Parse again (if necessary) to capture Haddock parse errors + if gopt Opt_Haddock dflags + then + liftIO mainParse + else do + let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock} + haddockParse = do + (_, (!diagsHaddock, _)) <- + getParsedModuleDefinition hscHaddock opt comp_pkgs file contents + return diagsHaddock + + ((fingerPrint, (diags, res)), diagsHaddock) <- + -- parse twice, with and without Haddocks, concurrently + -- we cannot ignore Haddock parse errors because files of + -- non-interest are always parsed with Haddocks + liftIO $ concurrently mainParse haddockParse + + return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res)) + +getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule)) +getParsedModuleDefinition packageState opt comp_pkgs file contents = do + (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents) + case res of + Nothing -> pure (Nothing, (diag, Nothing)) + Just (contents, modu) -> do + mbFingerprint <- if isNothing $ optShakeFiles opt + then pure Nothing + else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents + pure (mbFingerprint, (diag, Just modu)) + getLocatedImportsRule :: Rules () getLocatedImportsRule = define $ \GetLocatedImports file -> do - pm <- use_ GetParsedModule file - let ms = pm_mod_summary pm + ms <- use_ GetModSummary file let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] - env <- hscEnv <$> use_ GhcSession file - let dflags = addRelativeImport file pm $ hsc_dflags env + env_eq <- use_ GhcSession file + let env = hscEnv env_eq + let import_dirs = deps env_eq + let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env opt <- getIdeOptions (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource + diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Left (modName, Nothing)) Right (FileImport path) -> pure ([], Left (modName, Just path)) @@ -171,48 +258,109 @@ Nothing -> pure (concat diags, Nothing) Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports)) +type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a +execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) +execRawDepM act = + execStateT act + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty + , IntMap.empty + ) + -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation -rawDependencyInformation f = do - let (initialId, initialMap) = getPathId f emptyPathIdMap - go (IntSet.singleton $ getFilePathId initialId) - (RawDependencyInformation IntMap.empty initialMap) +rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation +rawDependencyInformation fs = do + (rdi, ss) <- execRawDepM (mapM_ go fs) + let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss + return (rdi { rawBootMap = bm }) where - go fs rawDepInfo = - case IntSet.minView fs of - -- Queue is empty - Nothing -> pure rawDepInfo - -- Pop f from the queue and process it - Just (f, fs) -> do - let fId = FilePathId f - importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId - case importsOrErr of - Nothing -> - -- File doesn’t parse - let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo - in go fs rawDepInfo' - Just (modImports, pkgImports) -> do - let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId)) - f pathMap (imp, mbPath) = case mbPath of - Nothing -> (pathMap, (imp, Nothing)) - Just path -> - let (pathId, pathMap') = getPathId path pathMap - in (pathMap', (imp, Just pathId)) - -- Convert paths in imports to ids and update the path map - let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports - -- Files that we haven’t seen before are added to the queue. - let newFiles = - IntSet.fromList (coerce $ mapMaybe snd modImports') - IntSet.\\ IntMap.keysSet (rawImports rawDepInfo) - let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo - go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap }) + go :: NormalizedFilePath -- ^ Current module being processed + -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId + go f = do + -- First check to see if we have already processed the FilePath + -- If we have, just return its Id but don't update any of the state. + -- Otherwise, we need to process its imports. + checkAlreadyProcessed f $ do + al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f + -- Get a fresh FilePathId for the new file + fId <- getFreshFid al + -- Adding an edge to the bootmap so we can make sure to + -- insert boot nodes before the real files. + addBootMap al fId + -- Try to parse the imports of the file + importsOrErr <- lift $ use GetLocatedImports f + case importsOrErr of + Nothing -> do + -- File doesn't parse so add the module as a failure into the + -- dependency information, continue processing the other + -- elements in the queue + modifyRawDepInfo (insertImport fId (Left ModuleParseError)) + return fId + Just (modImports, pkgImports) -> do + -- Get NFPs of the imports which have corresponding files + -- Imports either come locally from a file or from a package. + let (no_file, with_file) = splitImports modImports + (mns, ls) = unzip with_file + -- Recursively process all the imports we just learnt about + -- and get back a list of their FilePathIds + fids <- mapM (go . artifactFilePath) ls + -- Associate together the ModuleName with the FilePathId + let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids) + -- Insert into the map the information about this modules + -- imports. + modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports) + return fId + + checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId + checkAlreadyProcessed nfp k = do + (rawDepInfo, _) <- get + maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp) + + modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM () + modifyRawDepInfo f = modify (first f) + + addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM () + addBootMap al fId = + modify (\(rd, ss) -> (rd, if isBootLocation al + then IntMap.insert (getFilePathId fId) al ss + else ss)) + + getFreshFid :: ArtifactsLocation -> RawDepM FilePathId + getFreshFid al = do + (rawDepInfo, ss) <- get + let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo) + -- Insert the File into the bootmap if it's a boot module + let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map } + put (rawDepInfo', ss) + return fId + + -- Split in (package imports, local imports) + splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)] + -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)]) + splitImports = foldr splitImportsLoop ([],[]) + + splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls) + splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls) + + updateBootMap pm boot_mod_id ArtifactsLocation{..} bm = + if not artifactIsSource + then + let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation) + in case msource_mod_id of + Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm + Nothing -> bm + else bm + + dropBootSuffix :: ModLocation -> FilePath + dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src + dropBootSuffix _ = error "dropBootSuffix" + getDependencyInformationRule :: Rules () getDependencyInformationRule = define $ \GetDependencyInformation file -> do - rawDepInfo <- rawDependencyInformation file + rawDepInfo <- rawDependencyInformation [file] pure ([], Just $ processDependencyInformation rawDepInfo) reportImportCyclesRule :: Rules () @@ -240,12 +388,13 @@ , _message = "Cyclic module dependency between " <> showCycle mods , _code = Nothing , _relatedInformation = Nothing + , _tags = Nothing } where loc = srcSpanToLocation (getLoc imp) - fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp) + fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp) getModuleName file = do - pm <- use_ GetParsedModule file - pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm) + ms <- use_ GetModSummary file + pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) -- returns all transitive dependencies in topological order. @@ -253,7 +402,7 @@ getDependenciesRule :: Rules () getDependenciesRule = defineEarlyCutoff $ \GetDependencies file -> do - depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file + depInfo <- use_ GetDependencyInformation file let allFiles = reachableModules depInfo _ <- uses_ ReportImportCycles allFiles opts <- getIdeOptions @@ -265,50 +414,101 @@ getSpanInfoRule = define $ \GetSpanInfo file -> do tc <- use_ TypeCheck file - deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file - tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps) - (fileImports, _) <- use_ GetLocatedImports file packageState <- hscEnv <$> use_ GhcSession file - x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms + deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file + let tdeps = transitiveModuleDeps deps + +-- When possible, rely on the haddocks embedded in our interface files +-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' +#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) + let parsedDeps = [] +#else + parsedDeps <- uses_ GetParsedModule tdeps +#endif + + ifaces <- uses_ GetModIface tdeps + (fileImports, _) <- use_ GetLocatedImports file + let imports = second (fmap artifactFilePath) <$> fileImports + x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces) return ([], Just x) -- Typechecks a module. typeCheckRule :: Rules () -typeCheckRule = - define $ \TypeCheck file -> do - pm <- use_ GetParsedModule file - deps <- use_ GetDependencies file - packageState <- hscEnv <$> use_ GhcSession file - -- Figure out whether we need TemplateHaskell or QuasiQuotes support - let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState - file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm) - any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq - tms <- if any_uses_th_qq - -- If we use TH or QQ, we must obtain the bytecode - then do - bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps) - tmrs <- uses_ TypeCheck (transitiveModuleDeps deps) - pure (zipWith addByteCode bytecodes tmrs) - else uses_ TypeCheck (transitiveModuleDeps deps) - setPriority priorityTypeCheck - IdeOptions{ optDefer = defer} <- getIdeOptions - liftIO $ typecheckModule defer packageState tms pm - where - uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - addByteCode :: Linkable -> TcModuleResult -> TcModuleResult - addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } } +typeCheckRule = define $ \TypeCheck file -> do + pm <- use_ GetParsedModule file + -- do not generate interface files as this rule is called + -- for files of interest on every keystroke + typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles -generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) -generateCore file = do +data GenerateInterfaceFiles + = DoGenerateInterfaceFiles + | SkipGenerationOfInterfaceFiles + deriving (Show) + +-- This is factored out so it can be directly called from the GetModIface +-- rule. Directly calling this rule means that on the initial load we can +-- garbage collect all the intermediate typechecked modules rather than +-- retain the information forever in the shake graph. +typeCheckRuleDefinition + :: NormalizedFilePath -- ^ Path to source file + -> ParsedModule + -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ? + -> Action (IdeResult TcModuleResult) +typeCheckRuleDefinition file pm generateArtifacts = do + deps <- use_ GetDependencies file + hsc <- hscEnv <$> use_ GhcSession file + -- Figure out whether we need TemplateHaskell or QuasiQuotes support + let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc + file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm) + any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq + mirs <- uses_ GetModIface (transitiveModuleDeps deps) + bytecodes <- if any_uses_th_qq + then -- If we use TH or QQ, we must obtain the bytecode + fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps) + else + pure $ repeat Nothing + + setPriority priorityTypeCheck + IdeOptions { optDefer = defer } <- getIdeOptions + + addUsageDependencies $ liftIO $ do + res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm + case res of + (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do + diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm) + diagsHi <- generateAndWriteHiFile hsc tcm + return (diags <> diagsHi <> diagsHie, Just tcm) + (diags, res) -> + return (diags, snd <$> res) + where + unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc)) + uses_th_qq dflags = + xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags + + addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult) + addUsageDependencies a = do + r@(_, mtc) <- a + forM_ mtc $ \tc -> do + let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc))) + udep (UsageFile fp _h) = Just fp + udep _ = Nothing + -- Add a dependency on these files which are added by things like + -- qAddDependentFile + void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) + return r + + +generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails)) +generateCore runSimplifier file = do deps <- use_ GetDependencies file (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps) setPriority priorityGenerateCore packageState <- hscEnv <$> use_ GhcSession file - liftIO $ compileModule packageState tms tm + liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm generateCoreRule :: Rules () generateCoreRule = - define $ \GenerateCore -> generateCore + define $ \GenerateCore -> generateCore (RunSimplifier True) generateByteCodeRule :: Rules () generateByteCodeRule = @@ -317,7 +517,7 @@ (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps) session <- hscEnv <$> use_ GhcSession file (_, guts, _) <- use_ GenerateCore file - liftIO $ generateByteCode session tms tm guts + liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts -- A local rule type to get caching. We want to use newCache, but it has -- thread killed exception issues, so we lift it to a full rule. @@ -329,7 +529,7 @@ instance NFData GhcSessionIO instance Binary GhcSessionIO -newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq) +newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq)) instance Show GhcSessionFun where show _ = "GhcSessionFun" instance NFData GhcSessionFun where rnf !_ = () @@ -338,21 +538,120 @@ loadGhcSession = do defineNoFile $ \GhcSessionIO -> do opts <- getIdeOptions - liftIO $ GhcSessionFun <$> optGhcSession opts + GhcSessionFun <$> optGhcSession opts + -- This function should always be rerun because it consults a cache to + -- see what HscEnv needs to be used for the file, which can change. + -- However, it should also cut-off early if it's the same HscEnv as + -- last time defineEarlyCutoff $ \GhcSession file -> do GhcSessionFun fun <- useNoFile_ GhcSessionIO + alwaysRerun val <- fun $ fromNormalizedFilePath file + + -- TODO: What was this doing before? opts <- getIdeOptions - return ("" <$ optShakeFiles opts, ([], Just val)) + let cutoffHash = + case optShakeFiles opts of + -- optShakeFiles is only set in the DAML case. + -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915 + Just {} -> "" + -- Hash the HscEnvEq returned so cutoff if it didn't change + -- from last time + Nothing -> BS.pack (show (hash (snd val))) + return (Just cutoffHash, val) +getHiFileRule :: Rules () +getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do + -- get all dependencies interface files, to check for freshness + (deps,_) <- use_ GetLocatedImports f + depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps) -getHieFileRule :: Rules () -getHieFileRule = - defineNoFile $ \(GetHieFile f) -> do - u <- liftIO $ mkSplitUniqSupply 'a' - let nameCache = initNameCache u [] - liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f + ms <- use_ GetModSummary f + let hiFile = toNormalizedFilePath' + $ case ms_hsc_src ms of + HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms) + _ -> ml_hi_file $ ms_location ms + case sequence depHis of + Nothing -> pure (Nothing, ([], Nothing)) + Just deps -> do + gotHiFile <- getFileExists hiFile + if not gotHiFile + then pure (Nothing, ([], Nothing)) + else do + hiVersion <- use_ GetModificationTime hiFile + modVersion <- use_ GetModificationTime f + let sourceModified = modificationTime hiVersion < modificationTime modVersion + if sourceModified + then do + pure (Nothing, ([], Nothing)) + else do + session <- hscEnv <$> use_ GhcSession f + r <- liftIO $ loadInterface session ms deps + case r of + Right iface -> do + let result = HiFileResult ms iface + return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result)) + Left err -> do + let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err + return (Nothing, (pure diag, Nothing)) + +getModSummaryRule :: Rules () +getModSummaryRule = define $ \GetModSummary f -> do + dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f + (_, mFileContent) <- getFileContents f + modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $ + getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent) + return $ either (,Nothing) (([], ) . Just) modS + +getModIfaceRule :: Rules () +getModIfaceRule = define $ \GetModIface f -> do + fileOfInterest <- use_ IsFileOfInterest f + let useHiFile = + -- Never load interface files for files of interest + not fileOfInterest + mbHiFile <- if useHiFile then use GetHiFile f else return Nothing + case mbHiFile of + Just x -> + return ([], Just x) + Nothing + | fileOfInterest -> do + -- For files of interest only, create a Shake dependency on typecheck + tmr <- use TypeCheck f + return ([], extract tmr) + | otherwise -> do + -- the interface file does not exist or is out of date. + -- Invoke typechecking directly to update it without incurring a dependency + -- on the parsed module and the typecheck rules + sess <- use_ GhcSession f + let hsc = hscEnv sess + -- After parsing the module remove all package imports referring to + -- these packages as we have already dealt with what they map to. + comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess) + opt <- getIdeOptions + (_, contents) <- getFileContents f + -- Embed --haddocks in the interface file + hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock} + (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents + case mb_pm of + Nothing -> return (diags, Nothing) + Just pm -> do + (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles + -- Bang pattern is important to avoid leaking 'tmr' + let !res = extract tmr + return (diags <> diags', res) + where + extract Nothing = Nothing + extract (Just tmr) = + -- Bang patterns are important to force the inner fields + Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr) + +isFileOfInterestRule :: Rules () +isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do + filesOfInterest <- getFilesOfInterest + let res = f `elem` filesOfInterest + return (Just (if res then "1" else ""), ([], Just res)) + -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do @@ -366,4 +665,7 @@ generateCoreRule generateByteCodeRule loadGhcSession - getHieFileRule + getHiFileRule + getModIfaceRule + isFileOfInterestRule + getModSummaryRule diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -23,6 +23,7 @@ import Data.Maybe import Development.IDE.Types.Options (IdeOptions(..)) import Control.Monad +import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules) import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest @@ -49,14 +50,16 @@ -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Logger + -> Debouncer LSP.NormalizedUri -> IdeOptions -> VFSHandle -> IO IdeState -initialise caps mainRule getLspId toDiags logger options vfs = +initialise caps mainRule getLspId toDiags logger debouncer options vfs = shakeOpen getLspId toDiags logger + debouncer (optShakeProfiling options) (optReportProgress options) shakeOptions diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -19,8 +19,8 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, - ShakeExtras(..), getShakeExtras, + IdeState, shakeExtras, + ShakeExtras(..), getShakeExtras, getShakeExtrasRules, IdeRule, IdeResult, GetModificationTime(..), shakeOpen, shakeShut, shakeRun, @@ -30,13 +30,13 @@ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, getDiagnostics, unsafeClearDiagnostics, getHiddenDiagnostics, - IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction, + IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction, garbageCollect, setPriority, sendEvent, ideLogger, actionLogger, - FileVersion(..), + FileVersion(..), modificationTime, Priority(..), updatePositionMapping, deleteValue, @@ -49,12 +49,11 @@ import Development.Shake.Rule import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map -import qualified Data.Map.Merge.Strict as Map import qualified Data.ByteString.Char8 as BS import Data.Dynamic import Data.Maybe import Data.Map.Strict (Map) -import Data.List.Extra (foldl', partition, takeEnd) +import Data.List.Extra (partition, takeEnd) import qualified Data.Set as Set import qualified Data.Text as T import Data.Traversable (for) @@ -70,7 +69,7 @@ import Development.IDE.Types.Options import Control.Concurrent.Async import Control.Concurrent.Extra -import Control.Exception +import Control.Exception.Extra import Control.DeepSeq import System.Time.Extra import Data.Typeable @@ -95,13 +94,15 @@ ,state :: Var Values ,diagnostics :: Var DiagnosticStore ,hiddenDiagnostics :: Var DiagnosticStore - ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic]) + ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping)) + ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version - ,inProgress :: Var (Map NormalizedFilePath Int) + -- First mapping is delta from previous version and second one is an + -- accumlation of all previous mappings. + ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) -- ^ How many rules are running for each file } @@ -115,22 +116,29 @@ Just x <- getShakeExtraRules @ShakeExtras return x - - class Typeable a => IsIdeGlobal a where addIdeGlobal :: IsIdeGlobal a => a -> Rules () -addIdeGlobal x@(typeOf -> ty) = do - ShakeExtras{globals} <- getShakeExtrasRules +addIdeGlobal x = do + extras <- getShakeExtrasRules + liftIO $ addIdeGlobalExtras extras x + +addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO () +addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) = liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of - Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty + Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty Nothing -> return $! HMap.insert ty (toDyn x) mp getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a getIdeGlobalExtras ShakeExtras{globals} = do - Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals - return $ fromDyn x $ error "Serious error, corrupt globals" + let typ = typeRep (Proxy :: Proxy a) + x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals + case x of + Just x + | Just x <- fromDynamic x -> pure x + | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" + Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras @@ -153,7 +161,7 @@ | otherwise = False instance Hashable Key where - hashWithSalt salt (Key key) = hashWithSalt salt key + hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key) -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, -- and a value is in the Maybe. For operations that throw an error you @@ -163,9 +171,6 @@ -- get empty diagnostics and a Nothing, to indicate this phase throws no fresh -- errors but still failed. -- --- A rule on a file should only return diagnostics for that given file. It should --- not propagate diagnostic errors through multiple phases. -type IdeResult v = ([FileDiagnostic], Maybe v) data Value v = Succeeded TextDocumentVersion v @@ -200,14 +205,14 @@ Failed -> Nothing mappingForVersion - :: Map NormalizedUri (Map TextDocumentVersion PositionMapping) + :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath -> TextDocumentVersion -> PositionMapping mappingForVersion allMappings file ver = - fromMaybe idMapping $ + maybe zeroMapping snd $ Map.lookup ver =<< - Map.lookup (filePathToUri' file) allMappings + HMap.lookup (filePathToUri' file) allMappings type IdeRule k v = ( Shake.RuleResult k ~ v @@ -238,7 +243,6 @@ shakeProfileDatabase shakeDb $ dir file return (dir file) return (res, proFile) - where {-# NOINLINE profileStartTime #-} profileStartTime :: String @@ -294,21 +298,21 @@ shakeOpen :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler -> Logger + -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do - inProgress <- newVar Map.empty +shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do + inProgress <- newVar HMap.empty shakeExtras <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty hiddenDiagnostics <- newVar mempty publishedDiagnostics <- newVar mempty - debouncer <- newDebouncer - positionMapping <- newVar Map.empty + positionMapping <- newVar HMap.empty pure ShakeExtras{..} (shakeDb, shakeClose) <- shakeOpenDatabase @@ -323,7 +327,7 @@ shakeDb <- shakeDb return IdeState{..} -lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO () +lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO () lspShakeProgress getLspId sendMsg inProgress = do -- first sleep a bit, so we only show progress messages if it's going to take -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) @@ -356,8 +360,8 @@ loop id prev = do sleep sample current <- readVar inProgress - let done = length $ filter (== 0) $ Map.elems current - let todo = Map.size current + let done = length $ filter (== 0) $ HMap.elems current + let todo = HMap.size current let next = Just $ T.pack $ show done <> "/" <> show todo when (next /= prev) $ sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification @@ -413,8 +417,8 @@ Right _ -> "completed" profile = case res of Right (_, Just fp) -> - let link = case filePathToUri' $ toNormalizedFilePath fp of - NormalizedUri x -> x + let link = case filePathToUri' $ toNormalizedFilePath' fp of + NormalizedUri _ x -> x in ", profile saved at " <> T.unpack link _ -> "" let logMsg = logDebug logger $ T.pack $ @@ -452,9 +456,9 @@ return $! dupe values modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags - modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags + modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags let versionsForFile = - Map.fromListWith Set.union $ + HMap.fromListWith Set.union $ mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ HMap.toList newState modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings @@ -472,25 +476,25 @@ useWithStale key file = head <$> usesWithStale key [file] useNoFile :: IdeRule k v => k -> Action (Maybe v) -useNoFile key = use key "" +useNoFile key = use key emptyFilePath use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = head <$> uses_ key [file] useNoFile_ :: IdeRule k v => k -> Action v -useNoFile_ key = use_ key "" +useNoFile_ key = use_ key emptyFilePath uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v] uses_ key files = do res <- uses key files case sequence res of - Nothing -> liftIO $ throwIO BadDependency + Nothing -> liftIO $ throwIO $ BadDependency (show key) Just v -> return v -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action -data BadDependency = BadDependency deriving Show +data BadDependency = BadDependency String deriving Show instance Exception BadDependency isBadDependency :: SomeException -> Bool @@ -509,12 +513,10 @@ -- | Invariant: the 'v' must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database --- Note (MK) I am not sure why we need the ShakeValue here, maybe we --- can just remove it? -data A v = A (Value v) ShakeValue +newtype A v = A (Value v) deriving Show -instance NFData (A v) where rnf (A v x) = v `seq` rnf x +instance NFData (A v) where rnf (A v) = v `seq` () -- In the Shake database we only store one type of key/result pairs, -- namely Q (question) / A (answer). @@ -524,19 +526,22 @@ -- | Return up2date results. Stale results will be ignored. uses :: IdeRule k v => k -> [NormalizedFilePath] -> Action [Maybe v] -uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files) +uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files) -- | Return the last computed result which might be stale. usesWithStale :: IdeRule k v => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)] usesWithStale key files = do - values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files) - mapM (uncurry lastValue) (zip files values) + values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files) + zipWithM lastValue files values -withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b +withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b withProgress var file = actionBracket (f succ) (const $ f pred) . const - where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x defineEarlyCutoff @@ -553,16 +558,16 @@ case v of -- No changes in the dependencies and we have -- an existing result. - Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old) + Just v -> return $ Just $ RunResult ChangedNothing old $ A v _ -> return Nothing _ -> return Nothing case val of Just res -> return res Nothing -> do (bs, (diags, res)) <- actionCatch - (do v <- op key file; liftIO $ evaluate $ force $ v) $ + (do v <- op key file; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file + modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file (bs, res) <- case res of Nothing -> do staleV <- liftIO $ getValues state key file @@ -572,7 +577,7 @@ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v) Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v) Failed -> (toShakeValue ShakeResult bs, Failed) - Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v) + 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 let eq = case (bs, fmap decodeShakeValue old) of @@ -584,7 +589,7 @@ return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ - A res bs + A res -- | Rule type, input file @@ -655,12 +660,12 @@ needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action () needOnDisk k file = do successfull <- apply1 (QDisk k file) - liftIO $ unless successfull $ throwIO BadDependency + liftIO $ unless successfull $ throwIO $ BadDependency (show k) needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action () needOnDisks k files = do successfulls <- apply $ map (QDisk k) files - liftIO $ unless (and successfulls) $ throwIO BadDependency + liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue toShakeValue = maybe ShakeNoCutoff @@ -699,7 +704,7 @@ -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> Action () updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do - modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp + modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always @@ -712,7 +717,7 @@ let newDiags = getFileDiagnostics fp newDiagsStore _ <- evaluate newDiagsStore _ <- evaluate newDiags - pure $! (newDiagsStore, newDiags) + pure (newDiagsStore, newDiags) modifyVar_ hiddenDiagnostics $ \old -> do let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) (map snd currentHidden) old @@ -724,10 +729,10 @@ let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri $ do mask_ $ modifyVar_ publishedDiagnostics $ \published -> do - let lastPublish = Map.findWithDefault [] uri published + let lastPublish = HMap.lookupDefault [] uri published when (lastPublish /= newDiags) $ eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags - pure $! Map.insert uri newDiags published + pure $! HMap.insert uri newDiags published publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage publishDiagnosticsNotification uri diags = @@ -738,7 +743,7 @@ newtype Priority = Priority Double setPriority :: Priority -> Action () -setPriority (Priority p) = deprioritize p +setPriority (Priority p) = reschedule p sendEvent :: LSP.FromServerMessage -> Action () sendEvent e = do @@ -763,19 +768,22 @@ -- | Get the modification time of a file. type instance RuleResult GetModificationTime = FileVersion --- | We store the modification time as a ByteString since we need --- a ByteString anyway for Shake and we do not care about how times --- are represented. -data FileVersion = VFSVersion Int | ModificationTime BS.ByteString +data FileVersion + = VFSVersion !Int + | ModificationTime + !Int -- ^ Large unit (platform dependent, do not make assumptions) + !Int -- ^ Small unit (platform dependent, do not make assumptions) deriving (Show, Generic) instance NFData FileVersion vfsVersion :: FileVersion -> Maybe Int vfsVersion (VFSVersion i) = Just i -vfsVersion (ModificationTime _) = Nothing - +vfsVersion ModificationTime{} = Nothing +modificationTime :: FileVersion -> Maybe (Int, Int) +modificationTime VFSVersion{} = Nothing +modificationTime (ModificationTime large small) = Just (large, small) getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags @@ -800,7 +808,7 @@ DiagnosticStore -> [FileDiagnostic] getAllDiagnostics = - concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList + concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList getFileDiagnostics :: NormalizedFilePath -> @@ -808,29 +816,34 @@ [LSP.Diagnostic] getFileDiagnostics fp ds = maybe [] getDiagnosticsFromStore $ - Map.lookup (filePathToUri' fp) ds + HMap.lookup (filePathToUri' fp) ds filterDiagnostics :: (NormalizedFilePath -> Bool) -> DiagnosticStore -> DiagnosticStore filterDiagnostics keep = - Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri) + HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) filterVersionMap - :: Map NormalizedUri (Set.Set TextDocumentVersion) - -> Map NormalizedUri (Map TextDocumentVersion a) - -> Map NormalizedUri (Map TextDocumentVersion a) + :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) + -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) + -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) filterVersionMap = - Map.merge Map.dropMissing Map.dropMissing $ - Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep + HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do modifyVar_ positionMapping $ \allMappings -> do let uri = toNormalizedUri _uri - let mappingForUri = Map.findWithDefault Map.empty uri allMappings - let updatedMapping = - Map.insert _version idMapping $ - Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri - pure $! Map.insert uri updatedMapping allMappings + let mappingForUri = HMap.lookupDefault Map.empty uri allMappings + let (_, updatedMapping) = + -- Very important to use mapAccum here so that the tails of + -- each mapping can be shared, otherwise quadratic space is + -- used which is evident in long running sessions. + Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) + zeroMapping + (Map.insert _version (shared_change, zeroMapping) mappingForUri) + pure $! HMap.insert uri updatedMapping allMappings + where + shared_change = mkDelta changes diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -19,7 +19,8 @@ -- ----------------------------------------------------------------------------- -module Development.IDE.GHC.CPP(doCpp) where +module Development.IDE.GHC.CPP(doCpp, addOptP) +where import Development.IDE.GHC.Compat import Packages @@ -33,6 +34,10 @@ #elif MIN_GHC_API_VERSION(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif +#if MIN_GHC_API_VERSION (8,10,0) +import Fingerprint +import ToolSettings +#endif import System.Directory import System.FilePath @@ -59,7 +64,11 @@ let verbFlags = getVerbFlags dflags let cpp_prog args | raw = SysTools.runCpp dflags args +#if MIN_GHC_API_VERSION(8,10,0) + | otherwise = SysTools.runCc Nothing +#else | otherwise = SysTools.runCc +#endif dflags (SysTools.Option "-E" : args) let target_defs = @@ -157,6 +166,22 @@ getBackendDefs _ = return [] + +addOptP :: String -> DynFlags -> DynFlags +#if MIN_GHC_API_VERSION (8,10,0) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } +#else +addOptP opt = onSettings (onOptP (opt:)) + where + onSettings f x = x{settings = f $ settings x} + onOptP f x = x{sOpt_P = f $ sOpt_P x} +#endif -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal) diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -7,22 +7,38 @@ -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( + getHeaderImports, HieFileResult(..), - HieFile(..), + HieFile, + hieExportNames, + hie_module, mkHieFile, writeHieFile, readHieFile, + supportsHieFiles, + setDefaultHieDir, + dontWriteHieFiles, +#if !MIN_GHC_API_VERSION(8,8,0) + ml_hie_file, +#endif hPutStringBuffer, includePathsGlobal, includePathsQuote, addIncludePathsQuote, + getModuleHash, + getPackageName, pattern DerivD, pattern ForD, pattern InstD, pattern TyClD, pattern ValD, pattern ClassOpSig, + pattern IEThingAll, pattern IEThingWith, + GHC.ModLocation, + Module.addBootSuffix, + pattern ModLocation, + getConArgs, module GHC ) where @@ -30,41 +46,62 @@ import StringBuffer import DynFlags import FieldLabel +import Fingerprint (Fingerprint) +import qualified Module +import Packages import qualified GHC -import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD) +import GHC hiding ( + ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation +#if MIN_GHC_API_VERSION(8,6,0) + , getConArgs +#endif + ) +import qualified HeaderInfo as Hdr +import Avail +import ErrUtils (ErrorMessages) +import FastString (FastString) +#if MIN_GHC_API_VERSION(8,10,0) +import HscTypes (mi_mod_hash) +#endif + #if MIN_GHC_API_VERSION(8,8,0) -import HieAst +import Control.Applicative ((<|>)) +import Development.IDE.GHC.HieAst (mkHieFile) import HieBin import HieTypes + +supportsHieFiles :: Bool +supportsHieFiles = True + +hieExportNames :: HieFile -> [(SrcSpan, Name)] +hieExportNames = nameListFromAvails . hie_exports + #else -import GhcPlugins + +#if MIN_GHC_API_VERSION(8,6,0) +import BinIface +import Data.IORef +import IfaceEnv +#endif + +import Binary +import Control.Exception (catch) +import Data.ByteString (ByteString) +import GhcPlugins hiding (ModLocation) import NameCache -import Avail import TcRnTypes import System.IO import Foreign.ForeignPtr +import MkIface -#if !MIN_GHC_API_VERSION(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len -#endif -mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile -mkHieFile _ _ _ = return (HieFile () []) - -writeHieFile :: FilePath -> HieFile -> IO () -writeHieFile _ _ = return () - -readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ()) -readHieFile _ _ = return (HieFileResult (HieFile () []), ()) - -data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]} -data HieFileResult = HieFileResult { hie_file_result :: HieFile } #endif #if !MIN_GHC_API_VERSION(8,6,0) @@ -137,3 +174,136 @@ #else GHC.IEThingWith a b c d #endif + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation +pattern ModLocation a b c <- +#if MIN_GHC_API_VERSION(8,8,0) + GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" +#else + GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c +#endif + +pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass +pattern IEThingAll a <- +#if MIN_GHC_API_VERSION(8,6,0) + GHC.IEThingAll _ a +#else + GHC.IEThingAll a +#endif + +setDefaultHieDir :: FilePath -> DynFlags -> DynFlags +setDefaultHieDir _f d = +#if MIN_GHC_API_VERSION(8,8,0) + d { hieDir = hieDir d <|> Just _f} +#else + d +#endif + +dontWriteHieFiles :: DynFlags -> DynFlags +dontWriteHieFiles d = +#if MIN_GHC_API_VERSION(8,8,0) + gopt_unset d Opt_WriteHie +#else + d +#endif + +nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] +nameListFromAvails as = + map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) + +#if !MIN_GHC_API_VERSION(8,8,0) +-- Reimplementations of functions for HIE files for GHC 8.6 + +mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile +mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es) + where + es = nameListFromAvails (mkIfaceExports (tcg_exports ts)) + +ml_hie_file :: GHC.ModLocation -> FilePath +ml_hie_file ml = ml_hi_file ml ++ ".hie" + +data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]} + +hieExportNames :: HieFile -> [(SrcSpan, Name)] +hieExportNames = hie_exports + +instance Binary HieFile where + put_ bh (HieFile m es) = do + put_ bh m + put_ bh es + + get bh = do + mod <- get bh + es <- get bh + return (HieFile mod es) + +data HieFileResult = HieFileResult { hie_file_result :: HieFile } + +writeHieFile :: FilePath -> HieFile -> IO () +readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ()) +supportsHieFiles :: Bool + +#if MIN_GHC_API_VERSION(8,6,0) + +writeHieFile fp hie = do + bh <- openBinMem (1024 * 1024) + putWithUserData (const $ return ()) bh hie + writeBinMem bh fp + +readHieFile nc fp = do + bh <- readBinMem fp + nc' <- newIORef nc + hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh + return (HieFileResult hie_file, ()) + +supportsHieFiles = True + +#else + +supportsHieFiles = False + +writeHieFile _ _ = return () + +readHieFile _ _ = return undefined + +#endif + +#endif + +getHeaderImports + :: DynFlags + -> StringBuffer + -> FilePath + -> FilePath + -> IO + ( Either + ErrorMessages + ( [(Maybe FastString, Located ModuleName)] + , [(Maybe FastString, Located ModuleName)] + , Located ModuleName + ) + ) +#if MIN_GHC_API_VERSION(8,8,0) +getHeaderImports = Hdr.getImports +#else +getHeaderImports a b c d = + catch (Right <$> Hdr.getImports a b c d) + (return . Left . srcErrorMessages) +#endif + +getModuleHash :: ModIface -> Fingerprint +#if MIN_GHC_API_VERSION(8,10,0) +getModuleHash = mi_mod_hash . mi_final_exts +#else +getModuleHash = mi_mod_hash +#endif + +getConArgs :: ConDecl pass -> HsConDeclDetails pass +#if MIN_GHC_API_VERSION(8,6,0) +getConArgs = GHC.getConArgs +#else +getConArgs = GHC.getConDetails +#endif + +getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName +getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -9,6 +9,7 @@ , diagFromStrings , diagFromGhcException , catchSrcErrors + , mergeDiagnostics -- * utilities working with spans , srcSpanToLocation @@ -36,11 +37,12 @@ import ErrUtils import SrcLoc import qualified Outputable as Out +import Exception (ExceptionMonad) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,) +diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,) Diagnostic { _range = srcSpanToRange loc , _severity = Just sev @@ -48,18 +50,39 @@ , _message = msg , _code = Nothing , _relatedInformation = Nothing + , _tags = Nothing } -- | Produce a GHC-style error from a source span and a message. diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] diagFromErrMsg diagSource dflags e = - [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e + [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ + ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e | Just sev <- [toDSeverity $ errMsgSeverity e]] diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList +-- | Merges two sorted lists of diagnostics, removing duplicates. +-- Assumes all the diagnostics are for the same file. +mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] +mergeDiagnostics aa [] = aa +mergeDiagnostics [] bb = bb +mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb) + | ar < br + = a : mergeDiagnostics aa (b:bb) + | br < ar + = b : mergeDiagnostics (a:aa) bb + | _severity ad == _severity bd + && _source ad == _source bd + && _message ad == _message bd + && _code ad == _code bd + && _relatedInformation ad == _relatedInformation bd + && _tags ad == _tags bd + = a : mergeDiagnostics aa bb + | otherwise + = a : b : mergeDiagnostics aa bb -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Range @@ -80,7 +103,7 @@ srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation src = -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code - Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src) + Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = sp <= p && p <= ep @@ -127,7 +150,7 @@ -- | Run something in a Ghc monad and catch the errors (SourceErrors and -- compiler-internal exceptions like Panic or InstallationError). -catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a) +catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a) catchSrcErrors fromWhere ghcM = do dflags <- getDynFlags handleGhcException (ghcExceptionToDiagnostics dflags) $ diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -1,8 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +#include "ghc-api-version.h" -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. @@ -31,7 +33,7 @@ instance Show InstalledUnitId where show = installedUnitIdString -instance NFData InstalledUnitId where rnf = rwhnf +instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS instance NFData SB.StringBuffer where rnf = rwhnf @@ -40,8 +42,8 @@ instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint -instance NFData (GenLocated SrcSpan ModuleName) where - rnf = rwhnf +instance (NFData l, NFData e) => NFData (GenLocated l e) where + rnf (L l e) = rnf l `seq` rnf e instance Show ModSummary where show = show . ms_mod @@ -51,6 +53,11 @@ instance NFData ModSummary where rnf = rwhnf + +#if !MIN_GHC_API_VERSION(8,10,0) +instance NFData FastString where + rnf = rwhnf +#endif instance NFData ParsedModule where rnf = rwhnf diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -1,42 +1,44 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -- | General utility functions, mostly focused around GHC operations. module Development.IDE.GHC.Util( -- * HcsEnv and environment - HscEnvEq, hscEnv, newHscEnvEq, + HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq, modifyDynFlags, - fakeDynFlags, + evalGhcEnv, runGhcEnv, + deps, -- * GHC wrappers prettyPrint, + printRdrName, + printName, + ParseResult(..), runParser, lookupPackageConfig, + textToStringBuffer, + stringBufferToByteString, moduleImportPath, cgGutsToCoreModule, fingerprintToBS, fingerprintFromStringBuffer, -- * General utilities - textToStringBuffer, readFileUtf8, hDuplicateTo', + setDefaultHieDir, + dontWriteHieFiles ) where -import Config import Control.Concurrent import Data.List.Extra +import Data.ByteString.Internal (ByteString(..)) import Data.Maybe import Data.Typeable import qualified Data.ByteString.Internal as BS import Fingerprint -import GHC import GhcMonad -import GhcPlugins hiding (Unique) -import Data.IORef import Control.Exception +import Data.IORef +import Data.Version (showVersion, Version) import FileCleanup import Foreign.Ptr import Foreign.ForeignPtr @@ -47,16 +49,27 @@ import GHC.IO.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals -import Platform import Data.Unique import Development.Shake.Classes import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import qualified Data.ByteString as BS +import Lexer 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 Packages (getPackageConfigMap, lookupPackage') +import SrcLoc (mkRealSrcLoc) +import FastString (mkFastString) +import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags) +import Module (moduleNameSlashes, InstalledUnitId) +import OccName (parenSymOcc) +import RdrName (nameRdrName, rdrNameOcc) +import Development.IDE.GHC.Compat as GHC import Development.IDE.Types.Location @@ -89,87 +102,123 @@ textToStringBuffer :: T.Text -> StringBuffer textToStringBuffer = stringToStringBuffer . T.unpack +runParser :: DynFlags -> String -> P a -> ParseResult a +runParser flags str parser = unP parser parseState + where + filename = "" + location = mkRealSrcLoc (mkFastString filename) 1 1 + buffer = stringToStringBuffer str + parseState = mkPState flags buffer location --- | Pretty print a GHC value using 'fakeDynFlags'. +stringBufferToByteString :: StringBuffer -> ByteString +stringBufferToByteString StringBuffer{..} = PS buf cur len + +-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '. prettyPrint :: Outputable a => a -> String -prettyPrint = showSDoc fakeDynFlags . ppr +prettyPrint = showSDoc unsafeGlobalDynFlags . ppr +-- | Pretty print a 'RdrName' wrapping operators in parens +printRdrName :: RdrName -> String +printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn) + where + rn = rdrNameOcc name + +-- | Pretty print a 'Name' wrapping operators in parens +printName :: Name -> String +printName = printRdrName . nameRdrName + -- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required -- pieces, but designed to be more efficient than a standard 'runGhc'. -runGhcEnv :: HscEnv -> Ghc a -> IO a +evalGhcEnv :: HscEnv -> Ghc b -> IO b +evalGhcEnv env act = snd <$> runGhcEnv env act + +-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required +-- pieces, but designed to be more efficient than a standard 'runGhc'. +runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) runGhcEnv env act = do filesToClean <- newIORef emptyFilesToClean dirsToClean <- newIORef mempty let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} ref <- newIORef env{hsc_dflags=dflags} - unGhc act (Session ref) `finally` do + res <- unGhc act (Session ref) `finally` do cleanTempFiles dflags cleanTempDirs dflags - --- | A 'DynFlags' value where most things are undefined. It's sufficient to call pretty printing, --- but not much else. -fakeDynFlags :: DynFlags -fakeDynFlags = defaultDynFlags settings mempty - where - settings = Settings - { sTargetPlatform = platform - , sPlatformConstants = platformConstants - , sProgramName = "ghc" - , sProjectVersion = cProjectVersion -#if MIN_GHC_API_VERSION(8,6,0) - , sOpt_P_fingerprint = fingerprint0 -#endif - } - platform = Platform - { platformWordSize=8 - , platformOS=OSUnknown - , platformUnregisterised=True - } - platformConstants = PlatformConstants - { pc_DYNAMIC_BY_DEFAULT=False - , pc_WORD_SIZE=8 - } + (,res) <$> readIORef ref -- | Given a module location, and its parse tree, figure out what is the include directory implied by it. -- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory -- @\/usr\/Test@ should be on the include path to find sibling modules. -moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath +moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath -- The call to takeDirectory is required since DAML does not require that -- the file name matches the module name in the last component. -- Once that has changed we can get rid of this. -moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm +moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn -- This happens for single-component modules since takeDirectory "A" == "." | modDir == "." = Just pathDir | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir where - ms = GHC.pm_mod_summary pm - mod' = GHC.ms_mod ms -- A for module A.B modDir = takeDirectory $ - fromNormalizedFilePath $ toNormalizedFilePath $ - moduleNameSlashes $ GHC.moduleName mod' + fromNormalizedFilePath $ toNormalizedFilePath' $ + moduleNameSlashes mn -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. -data HscEnvEq = HscEnvEq Unique HscEnv +data HscEnvEq + = HscEnvEq !Unique !HscEnv + [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv + -- This is only used at the moment for the import dirs in + -- the DynFlags + | GhcVersionMismatch { compileTime :: !Version + , runTime :: !Version + } -- | Unwrap an 'HsEnvEq'. hscEnv :: HscEnvEq -> HscEnv -hscEnv (HscEnvEq _ x) = x +hscEnv = either error id . hscEnv' +hscEnv' :: HscEnvEq -> Either String HscEnv +hscEnv' (HscEnvEq _ x _) = Right x +hscEnv' GhcVersionMismatch{..} = Left $ + unwords + ["ghcide compiled against GHC" + ,showVersion compileTime + ,"but currently using" + ,showVersion runTime + ,". This is unsupported, ghcide must be compiled with the same GHC version as the project." + ] + +deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)] +deps (HscEnvEq _ _ u) = u +deps GhcVersionMismatch{} = [] + -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: HscEnv -> IO HscEnvEq -newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e +newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids instance Show HscEnvEq where - show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a) + show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a) + show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime) instance Eq HscEnvEq where - HscEnvEq a _ == HscEnvEq b _ = a == b + HscEnvEq a _ _ == HscEnvEq b _ _ = a == b + GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d + _ == _ = False instance NFData HscEnvEq where - rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` () + rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` () + rnf GhcVersionMismatch{} = rnf runTime + +instance Hashable HscEnvEq where + hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a + hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime) + +-- Fake instance needed to persuade Shake to accept this type as a key. +-- No harm done as ghcide never persists these keys currently +instance Binary HscEnvEq where + put _ = error "not really" + get = error "not really" -- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error. readFileUtf8 :: FilePath -> IO T.Text diff --git a/src/Development/IDE/GHC/WithDynFlags.hs b/src/Development/IDE/GHC/WithDynFlags.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/WithDynFlags.hs @@ -0,0 +1,30 @@ +module Development.IDE.GHC.WithDynFlags +( WithDynFlags +, evalWithDynFlags +) where + +import Control.Monad.Trans.Reader (ask, ReaderT(..)) +import GHC (DynFlags) +import Control.Monad.IO.Class (MonadIO) +import Exception (ExceptionMonad(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import GhcPlugins (HasDynFlags(..)) + +-- | A monad transformer implementing the 'HasDynFlags' effect +newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a} + deriving (Applicative, Functor, Monad, MonadIO, MonadTrans) + +evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a +evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags + +instance Monad m => HasDynFlags (WithDynFlags m) where + getDynFlags = WithDynFlags ask + +instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where + gmask f = WithDynFlags $ ReaderT $ \env -> + gmask $ \restore -> + let restore' = lift . restore . flip runReaderT env . withDynFlags + in runReaderT (withDynFlags $ f restore') env + + gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env -> + gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle) diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -9,26 +9,33 @@ , ModuleParseError(..) , TransitiveDependencies(..) , FilePathId(..) + , NamedModuleDep(..) , PathIdMap , emptyPathIdMap , getPathId + , lookupPathToId , insertImport , pathToId , idToPath , reachableModules - , processDependencyInformation , transitiveDeps + + , BootIdMap + , insertBootId ) where import Control.DeepSeq import Data.Bifunctor import Data.Coerce import Data.List +import Data.Tuple.Extra hiding (first, second) import Development.IDE.GHC.Orphans() import Data.Either import Data.Graph +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.IntMap (IntMap) @@ -36,16 +43,14 @@ import qualified Data.IntMap.Lazy as IntMapLazy import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet -import Data.Map (Map) -import qualified Data.Map.Strict as MS import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import Data.Tuple.Extra (fst3) import GHC.Generics (Generic) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.Import.FindImports (ArtifactsLocation(..)) import GHC import Module @@ -57,69 +62,100 @@ -- that module on disk (if we found it) , packageImports :: !(Set InstalledUnitId) -- ^ Transitive package dependencies unioned for all imports. - } + } deriving Show --- | For processing dependency information, we need lots of maps and sets --- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet --- instead and only convert at the edges --- and +-- | For processing dependency information, we need lots of maps and sets of +-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet +-- instead and only convert at the edges. newtype FilePathId = FilePathId { getFilePathId :: Int } deriving (Show, NFData, Eq, Ord) +-- | Map from 'FilePathId' +type FilePathIdMap = IntMap + +-- | Set of 'FilePathId's +type FilePathIdSet = IntSet + data PathIdMap = PathIdMap - { idToPathMap :: !(IntMap NormalizedFilePath) - , pathToIdMap :: !(Map NormalizedFilePath FilePathId) + { idToPathMap :: !(FilePathIdMap ArtifactsLocation) + , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId) } deriving (Show, Generic) instance NFData PathIdMap emptyPathIdMap :: PathIdMap -emptyPathIdMap = PathIdMap IntMap.empty MS.empty +emptyPathIdMap = PathIdMap IntMap.empty HMS.empty -getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap) +getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap) getPathId path m@PathIdMap{..} = - case MS.lookup path pathToIdMap of + case HMS.lookup (artifactFilePath path) pathToIdMap of Nothing -> - let !newId = FilePathId $ MS.size pathToIdMap + let !newId = FilePathId $ HMS.size pathToIdMap in (newId, insertPathId path newId m) Just id -> (id, m) -insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap +insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap insertPathId path id PathIdMap{..} = - PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap) + PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap) insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId -pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path +pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path +lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId +lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap + idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath -idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id +idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId +idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation +idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id + +type BootIdMap = FilePathIdMap FilePathId + +insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap +insertBootId k = IntMap.insert (getFilePathId k) + -- | Unprocessed results that we find by following imports recursively. data RawDependencyInformation = RawDependencyInformation - { rawImports :: !(IntMap (Either ModuleParseError ModuleImports)) + { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports)) , rawPathIdMap :: !PathIdMap - } + -- The rawBootMap maps the FilePathId of a hs-boot file to its + -- corresponding hs file. It is used when topologically sorting as we + -- need to add edges between .hs-boot and .hs so that the .hs files + -- appear later in the sort. + , rawBootMap :: !BootIdMap + } deriving Show -pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId) +pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId) pkgDependencies RawDependencyInformation{..} = IntMap.map (either (const Set.empty) packageImports) rawImports data DependencyInformation = DependencyInformation - { depErrorNodes :: !(IntMap (NonEmpty NodeError)) + { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModuleDeps :: !(IntMap IntSet) + , depModuleNames :: !(FilePathIdMap ShowableModuleName) + , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. - , depPkgDeps :: !(IntMap (Set InstalledUnitId)) + , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId)) -- ^ For a non-error node, this contains the set of immediate pkg deps. , depPathIdMap :: !PathIdMap + -- ^ Map from FilePath to FilePathId + , depBootMap :: !BootIdMap + -- ^ Map from hs-boot file to the corresponding hs file } deriving (Show, Generic) +newtype ShowableModuleName = + ShowableModuleName {showableModuleName :: ModuleName} + deriving NFData + +instance Show ShowableModuleName where show = moduleNameString . showableModuleName + reachableModules :: DependencyInformation -> [NormalizedFilePath] reachableModules DependencyInformation{..} = map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps @@ -186,23 +222,32 @@ DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps + , depModuleNames = IntMap.fromList $ coerce moduleNames , depPkgDeps = pkgDependencies rawDepInfo , depPathIdMap = rawPathIdMap + , depBootMap = rawBootMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph + moduleNames :: [(FilePathId, ModuleName)] + moduleNames = + [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports] successEdges :: [(FilePathId, FilePathId, [FilePathId])] successEdges = - map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes + map + (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) + successNodes moduleDeps = - IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges + IntMap.fromList $ + map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) + successEdges -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: -- 1. Mark each node that is part of an import cycle as an error node. -- 2. Mark each node that has a parse error as an error node. -- 3. Mark each node whose immediate children could not be located as an error. -- 4. Recursively propagate errors to parents if they are not already error nodes. -buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult +buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult buildResultGraph g = propagatedErrors where sccs = stronglyConnComp (graphEdges g) @@ -249,7 +294,7 @@ Right ModuleImports{moduleImports} -> fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports -graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])] +graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])] graphEdges g = map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g where deps :: Either e ModuleImports -> [FilePathId] @@ -261,29 +306,71 @@ partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest partitionSCC [] = ([], []) + transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do let !fileId = pathToId depPathIdMap file reachableVs <- + -- Delete the starting node IntSet.delete (getFilePathId fileId) . IntSet.fromList . map (fst3 . fromVertex) . reachable g <$> toVertex (getFilePathId fileId) - let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs + let transitiveModuleDepIds = + filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs let transitivePkgDeps = Set.toList $ Set.unions $ map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $ getFilePathId fileId : transitiveModuleDepIds - let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds + let transitiveModuleDeps = + map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds + let transitiveNamedModuleDeps = + [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation + | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames + , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid + ] pure TransitiveDependencies {..} - where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps) - vs = topSort g + where + (g, fromVertex, toVertex) = graphFromEdges edges + edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps + -- Need to add an edge between the .hs and .hs-boot file if it exists + -- so the .hs file gets loaded after the .hs-boot file and the right + -- stuff ends up in the HPT. If you don't have this check then GHC will + -- fail to work with ghcide. + boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]] + + vs = topSort g + data TransitiveDependencies = TransitiveDependencies { transitiveModuleDeps :: [NormalizedFilePath] -- ^ Transitive module dependencies in topological order. -- The module itself is not included. + , transitiveNamedModuleDeps :: [NamedModuleDep] + -- ^ Transitive module dependencies in topological order. + -- The module itself is not included. , transitivePkgDeps :: [InstalledUnitId] -- ^ Transitive pkg dependencies in unspecified order. } deriving (Eq, Show, Generic) instance NFData TransitiveDependencies + +data NamedModuleDep = NamedModuleDep { + nmdFilePath :: !NormalizedFilePath, + nmdModuleName :: !ModuleName, + nmdModLocation :: !ModLocation + } + deriving Generic + +instance Eq NamedModuleDep where + a == b = nmdFilePath a == nmdFilePath b + +instance NFData NamedModuleDep where + rnf NamedModuleDep{..} = + rnf nmdFilePath `seq` + rnf nmdModuleName `seq` + -- 'ModLocation' lacks an 'NFData' instance + rwhnf nmdModLocation + +instance Show NamedModuleDep where + show NamedModuleDep{..} = show nmdFilePath + diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -7,16 +7,19 @@ module Development.IDE.Import.FindImports ( locateModule , Import(..) + , ArtifactsLocation(..) + , modSummaryToArtifactsLocation + , isBootLocation + , mkImportDirs ) where import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans() import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.GHC.Compat -- GHC imports -import DynFlags import FastString -import GHC import qualified Module as M import Packages import Outputable (showSDoc, ppr, pprPanic) @@ -27,64 +30,107 @@ import Control.Monad.Extra import Control.Monad.IO.Class import System.FilePath +import DriverPhases +import Data.Maybe data Import - = FileImport !NormalizedFilePath + = FileImport !ArtifactsLocation | PackageImport !M.InstalledUnitId deriving (Show) +data ArtifactsLocation = ArtifactsLocation + { artifactFilePath :: !NormalizedFilePath + , artifactModLocation :: !ModLocation + , artifactIsSource :: !Bool -- ^ True if a module is a source input + } + deriving (Show) + +instance NFData ArtifactsLocation where + rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource + +isBootLocation :: ArtifactsLocation -> Bool +isBootLocation = not . artifactIsSource + instance NFData Import where rnf (FileImport x) = rnf x rnf (PackageImport x) = rnf x +modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms)) + where + isSource HsSrcFile = True + isSource _ = False + -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m - => DynFlags + => [[FilePath]] -> [String] -> (NormalizedFilePath -> m Bool) -> Bool -> ModuleName -> m (Maybe NormalizedFilePath) -locateModuleFile dflags exts doesExist isSource modName = do - let candidates = - [ toNormalizedFilePath (prefix M.moduleNameSlashes modName <.> maybeBoot ext) - | prefix <- importPaths dflags, ext <- exts] - findM doesExist candidates +locateModuleFile import_dirss exts doesExist isSource modName = do + let candidates import_dirs = + [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) + | prefix <- import_dirs , ext <- exts] + findM doesExist (concatMap candidates import_dirss) where maybeBoot ext | isSource = ext ++ "-boot" | otherwise = ext +-- | This function is used to map a package name to a set of import paths. +-- It only returns Just for unit-ids which are possible to import into the +-- current module. In particular, it will return Nothing for 'main' components +-- as they can never be imported into another package. +mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i + -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m => DynFlags + -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in -> [String] -> (NormalizedFilePath -> m Bool) -> Located ModuleName -> Maybe FastString -> Bool -> m (Either [FileDiagnostic] Import) -locateModule dflags exts doesExist modName mbPkgName isSource = do +locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do - mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName - case mbFile of - Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] - Just file -> return $ Right $ FileImport file + lookupLocal [importPaths dflags] -- if a package name is given we only go look for a package - Just _pkgName -> lookupInPackageDB dflags + Just pkgName + | Just dirs <- lookup (PackageName pkgName) import_paths + -> lookupLocal [dirs] + | otherwise -> lookupInPackageDB dflags Nothing -> do -- first try to find the module as a file. If we can't find it try to find it in the package -- database. - mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName + -- Here the importPaths for the current modules are added to the front of the import paths from the other components. + -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in + -- each component will end up being found in the wrong place and cause a multi-cradle match failure. + mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName case mbFile of Nothing -> lookupInPackageDB dflags - Just file -> return $ Right $ FileImport file + Just file -> toModLocation file where + import_paths = mapMaybe (mkImportDirs dflags) comp_info + toModLocation file = liftIO $ do + loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) + return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource) + + lookupLocal dirs = do + mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName + case mbFile of + Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] + Just file -> toModLocation file + lookupInPackageDB dfs = case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -6,6 +6,9 @@ module Development.IDE.LSP.HoverDefinition ( setHandlersHover , setHandlersDefinition + -- * For haskell-language-server + , hover + , gotoDefinition ) where import Development.IDE.Core.Rules @@ -29,7 +32,7 @@ foundHover (mbRange, contents) = Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersHover :: PartialHandlers +setHandlersDefinition, setHandlersHover :: PartialHandlers c setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition} setHandlersHover = PartialHandlers $ \WithMessage{..} x -> @@ -52,7 +55,7 @@ logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do - let filePath = toNormalizedFilePath path + let filePath = toNormalizedFilePath' path logInfo (ideLogger ide) $ label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -28,21 +28,25 @@ import System.IO import Control.Monad.Extra +import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Shake import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Notifications import Development.IDE.LSP.Outline -import Development.IDE.Core.Service import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages runLanguageServer - :: LSP.Options - -> PartialHandlers + :: forall config. (Show config) + => LSP.Options + -> PartialHandlers config + -> (InitializeRequest -> Either T.Text config) + -> (DidChangeConfigurationNotification -> Either T.Text config) -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState) -> IO () -runLanguageServer options userHandlers getIdeState = do +runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do -- Move stdout to another file descriptor and duplicate stderr -- to stdout. This guards against stray prints from corrupting the JSON-RPC -- message stream. @@ -59,7 +63,7 @@ -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available - clientMsgChan :: Chan Message <- newChan + clientMsgChan :: Chan (Message config) <- newChan -- These barriers are signaled when the threads reading from these chans exit. -- This should not happen but if it does, we will make sure that the whole server @@ -78,6 +82,7 @@ let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do atomically $ modifyTVar pendingRequests (Set.insert _id) writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f + let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x) let cancelRequest reqId = atomically $ do queued <- readTVar pendingRequests -- We want to avoid that the list of cancelled requests @@ -94,6 +99,7 @@ cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry let PartialHandlers parts = + initializeRequestHandler <> setHandlersIgnore <> -- least important setHandlersDefinition <> setHandlersHover <> setHandlersOutline <> @@ -102,11 +108,11 @@ cancelHandler cancelRequest -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def + handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def let initializeCallbacks = LSP.InitializeCallbacks - { LSP.onInitialConfiguration = const $ Right () - , LSP.onConfigurationChange = const $ Right () + { LSP.onInitialConfiguration = onInitialConfig + , LSP.onConfigurationChange = onConfigChange , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan } @@ -121,9 +127,11 @@ , void $ waitBarrier clientMsgBarrier ] where - handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err) + handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err) handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do + ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities + _ <- flip forkFinally (const exitClientMsg) $ forever $ do msg <- readChan clientMsgChan case msg of @@ -136,17 +144,23 @@ Response x@RequestMessage{_id, _params} wrap act -> checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \case - Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e) - Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing + Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) + Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act -> checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \(res, newReq) -> do - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing - case newReq of - Nothing -> return () - Just (rm, newReqParams) -> do + case res of + Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) + Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) + whenJust newReq $ \(rm, newReqParams) -> do reqId <- getNextReqId sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams + InitialParams x@RequestMessage{_id, _params} act -> do + catch (act lspFuncs ide _params) $ \(e :: SomeException) -> + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on InitializeRequest handler, please report!\n" ++ + "Message: " ++ show x ++ "\n" ++ + "Exception: " ++ show e pure Nothing checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k = @@ -161,28 +175,39 @@ Left () -> do logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ - Just $ ResponseError RequestCancelled "" Nothing + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left + $ ResponseError RequestCancelled "" Nothing Right res -> k res ) $ \(e :: SomeException) -> do logError (ideLogger ide) $ T.pack $ "Unexpected exception on request, please report!\n" ++ "Message: " ++ show msg ++ "\n" ++ "Exception: " ++ show e - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ - Just $ ResponseError InternalError (T.pack $ show e) Nothing + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left + $ ResponseError InternalError (T.pack $ show e) Nothing +initializeRequestHandler :: PartialHandlers config +initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.initializeRequestHandler = withInitialize initHandler + } +initHandler + :: LSP.LspFuncs c + -> IdeState + -> InitializeParams + -> IO () +initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params) + -- | Things that get sent to us, but we don't deal with. -- Set them to avoid a warning in VS Code output. -setHandlersIgnore :: PartialHandlers +setHandlersIgnore :: PartialHandlers config setHandlersIgnore = PartialHandlers $ \_ x -> return x {LSP.initializedHandler = none ,LSP.responseHandler = none } where none = Just $ const $ return () -cancelHandler :: (LspId -> IO ()) -> PartialHandlers +cancelHandler :: (LspId -> IO ()) -> PartialHandlers config cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do cancelRequest _id @@ -192,19 +217,18 @@ -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety -- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) -data Message - = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) +data Message c + = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -- | Used for cases in which we need to send not only a response, -- but also an additional request to the client. -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request. - | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) - | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ()) - + | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) + | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ()) + -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler. + | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS - , LSP.executeCommandCommands = Just ["typesignature.add"] - , LSP.completionTriggerCharacters = Just "." } where tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing} diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -13,6 +13,7 @@ import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as LSP +import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service import Development.IDE.Types.Location import Development.IDE.Types.Logger @@ -20,7 +21,7 @@ import Control.Monad.Extra import Data.Foldable as F import Data.Maybe -import qualified Data.Set as S +import qualified Data.HashSet as S import qualified Data.Text as Text import Development.IDE.Core.FileStore (setSomethingModified) @@ -29,9 +30,9 @@ whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () -whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath +whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -setHandlersNotifications :: PartialHandlers +setHandlersNotifications :: PartialHandlers c setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $ \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do @@ -61,7 +62,7 @@ let events = mapMaybe (\(FileEvent uri ev) -> - (, ev /= FcDeleted) . toNormalizedFilePath + (, ev /= FcDeleted) . toNormalizedFilePath' <$> LSP.uriToFilePath uri ) ( F.toList fileEvents ) @@ -69,4 +70,12 @@ logInfo (ideLogger ide) $ "Files created or deleted: " <> msg modifyFileExists ide events setSomethingModified ide + + ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $ + \_ ide (DidChangeWorkspaceFoldersParams events) -> do + let add = S.union + substract = flip S.difference + modifyWorkspaceFolders ide + $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) + . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) } diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -4,6 +4,8 @@ module Development.IDE.LSP.Outline ( setHandlersOutline + -- * For haskell-language-server + , moduleOutline ) where @@ -28,20 +30,20 @@ , showSDocUnsafe ) -setHandlersOutline :: PartialHandlers +setHandlersOutline :: PartialHandlers c setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline } moduleOutline - :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult) + :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult) moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri } = case uriToFilePath uri of - Just (toNormalizedFilePath -> fp) -> do + Just (toNormalizedFilePath' -> fp) -> do mb_decls <- runAction ideState $ use GetParsedModule fp pure $ Right $ case mb_decls of Nothing -> DSDocumentSymbols (List []) - Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }) + Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName <&> \(L l m) -> @@ -50,7 +52,9 @@ , _kind = SkFile , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } - importSymbols = mapMaybe documentSymbolForImport hsmodImports + importSymbols = maybe [] pure $ + documentSymbolForImportSummary + (mapMaybe documentSymbolForImport hsmodImports) allSymbols = case moduleSymbol of Nothing -> importSymbols <> declSymbols Just x -> @@ -104,27 +108,39 @@ { _name = showRdrName n , _kind = SkConstructor , _selectionRange = srcSpanToRange l' + , _children = conArgRecordFields (getConArgs x) } | L l x <- dd_cons , L l' n <- getConNames x ] } + where + -- | Extract the record fields of a constructor + conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List + [ (defDocumentSymbol l :: DocumentSymbol) + { _name = showRdrName n + , _kind = SkField + } + | L _ cdf <- lcdfs + , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + ] + conArgRecordFields _ = Nothing documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = srcSpanToRange l' } -documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))) +documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) })) +documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) })) +documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) @@ -167,12 +183,35 @@ documentSymbolForDecl _ = Nothing +-- | Wrap the Document imports into a hierarchical outline for +-- a better overview of symbols in scope. +-- If there are no imports, then no hierarchy will be created. +documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol +documentSymbolForImportSummary [] = Nothing +documentSymbolForImportSummary importSymbols = + let + -- safe because if we have no ranges then we don't take this branch + mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) + importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols + in + Just (defDocumentSymbol empty :: DocumentSymbol) + { _name = "imports" + , _kind = SkModule + , _children = Just (List importSymbols) + , _range = importRange + , _selectionRange = importRange + } + documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule +#if MIN_GHC_API_VERSION(8,10,0) + , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } +#else , _detail = if ideclQualified then Just "qualified" else Nothing +#endif } #if MIN_GHC_API_VERSION(8,6,0) documentSymbolForImport (L _ XImportDecl {}) = Nothing diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -16,30 +16,32 @@ import qualified Language.Haskell.LSP.Messages as LSP import Development.IDE.Core.Service -data WithMessage = WithMessage +data WithMessage c = WithMessage {withResponse :: forall m req resp . (Show m, Show req) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response - (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work + (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work Maybe (LSP.Handler (RequestMessage m req resp)) ,withNotification :: forall m req . (Show m, Show req) => Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler - (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work + (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work Maybe (LSP.Handler (NotificationMessage m req)) - ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody. + ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req - (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work + (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work Maybe (LSP.Handler (RequestMessage m req resp)) + , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) + -> Maybe (LSP.Handler InitializeRequest) } -newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers) +newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers) -instance Default PartialHandlers where +instance Default (PartialHandlers c) where def = PartialHandlers $ \_ x -> pure x -instance Semigroup PartialHandlers where +instance Semigroup (PartialHandlers c) where PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w -instance Monoid PartialHandlers where +instance Monoid (PartialHandlers c) where mempty = def diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -1,34 +1,60 @@ -module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where +module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where import Data.Default +import qualified Data.Text as T import Development.Shake import Development.IDE.LSP.Server import Language.Haskell.LSP.Types +import Development.IDE.Compat import Development.IDE.Core.Rules import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages -data Plugin = Plugin +data Plugin c = Plugin {pluginRules :: Rules () - ,pluginHandler :: PartialHandlers + ,pluginHandler :: PartialHandlers c } -instance Default Plugin where +instance Default (Plugin c) where def = Plugin mempty def -instance Semigroup Plugin where +instance Semigroup (Plugin c) where Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2) -instance Monoid Plugin where +instance Monoid (Plugin c) where mempty = def -codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin -codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{ +codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c +codeActionPlugin = codeActionPluginWithRules mempty + +codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c +codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{ LSP.codeActionHandler = withResponse RspCodeAction g } where g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c + +-- | Prefix to uniquely identify commands sent to the client. This +-- has two parts +-- +-- - A representation of the process id to make sure that a client has +-- unique commands if it is running multiple servers, since some +-- clients have a global command table and get confused otherwise. +-- +-- - A string to identify ghcide, to ease integration into +-- haskell-language-server, which routes commands to plugins based +-- on that. +makeLspCommandId :: T.Text -> IO T.Text +makeLspCommandId command = do + pid <- getPid + return $ pid <> ":ghcide:" <> command + +-- | Get the operating system process id for the running server +-- instance. This should be the same for the lifetime of the instance, +-- and different from that of any other currently running instance. +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -6,8 +6,17 @@ #include "ghc-api-version.h" -- | Go to the definition of a variable. -module Development.IDE.Plugin.CodeAction(plugin) where +module Development.IDE.Plugin.CodeAction + ( + plugin + -- * For haskell-language-server + , codeAction + , codeLens + , rulePackageExports + , executeAddSignatureCommand + ) where + import Language.Haskell.LSP.Types import Control.Monad (join) import Development.IDE.Plugin @@ -17,9 +26,14 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.GHC.Error +import Development.IDE.GHC.Util import Development.IDE.LSP.Server +import Development.IDE.Plugin.CodeAction.PositionIndexed +import Development.IDE.Plugin.CodeAction.RuleTypes +import Development.IDE.Plugin.CodeAction.Rules import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.Shake (Rules) import qualified Data.HashMap.Strict as Map import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.VFS @@ -32,18 +46,23 @@ import Data.List.Extra import qualified Data.Text as T import Data.Tuple.Extra ((&&&)) +import HscTypes +import Parser import Text.Regex.TDFA ((=~), (=~~)) import Text.Regex.TDFA.Text() import Outputable (ppr, showSDocUnsafe) import DynFlags (xFlags, FlagSpec(..)) import GHC.LanguageExtensions.Type (Extension) -plugin :: Plugin -plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens +plugin :: Plugin c +plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens +rules :: Rules () +rules = rulePackageExports + -- | Generate code actions. codeAction - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range @@ -54,30 +73,35 @@ -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents - (ideOptions, parsedModule) <- runAction state $ - (,) <$> getIdeOptions - <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri + mbFile = toNormalizedFilePath' <$> uriToFilePath uri + (ideOptions, parsedModule, join -> env) <- runAction state $ + (,,) <$> getIdeOptions + <*> getParsedModule `traverse` mbFile + <*> use GhcSession `traverse` mbFile + pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env + let dflags = hsc_dflags . hscEnv <$> env pure $ Right [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing - | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x + | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] -- | Generate code lenses. codeLens - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + commandId <- makeLspCommandId "typesignature.add" fmap (Right . List) $ case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do + Just (toNormalizedFilePath' -> filePath) -> do _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath diag <- getDiagnostics ideState hDiag <- getHiddenDiagnostics ideState pure - [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing - | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag + [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing + | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag , dFile == filePath , (title, tedit) <- suggestSignature False dDiag , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing @@ -86,22 +110,33 @@ -- | Execute the "typesignature.add" command. executeAddSignatureCommand - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> ExecuteCommandParams - -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} - | _command == "typesignature.add" + -- _command is prefixed with a process ID, because certain clients + -- have a global command registry, and all commands must be + -- unique. And there can be more than one ghcide instance running + -- at a time against the same client. + | T.isSuffixOf "typesignature.add" _command , Just (List [edit]) <- _arguments , Success wedit <- fromJSON edit - = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) + = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) | otherwise - = return (Null, Nothing) + = return (Right Null, Nothing) -suggestAction :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction ideOptions parsedModule text diag = concat +suggestAction + :: Maybe DynFlags + -> PackageExportsMap + -> IdeOptions + -> Maybe ParsedModule + -> Maybe T.Text + -> Diagnostic + -> [(T.Text, [TextEdit])] +suggestAction dflags packageExports ideOptions parsedModule text diag = concat [ suggestAddExtension diag - , suggestExtendImport text diag + , suggestExtendImport dflags text diag , suggestFillHole diag , suggestFillTypeWildcard diag , suggestFixConstructorImport text diag @@ -111,17 +146,19 @@ ] ++ concat [ suggestNewDefinition ideOptions pm text diag ++ suggestRemoveRedundantImport pm text diag + ++ suggestNewImport packageExports pm diag | Just pm <- [parsedModule]] suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..} +suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports , Just c <- contents , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings) , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges) + , not (null ranges') = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )] -- File.hs:16:1: warning: @@ -133,7 +170,7 @@ | otherwise = [] suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..} +suggestReplaceIdentifier contents Diagnostic{_range=_range,..} -- File.hs:52:41: error: -- * Variable not in scope: -- suggestAcion :: Maybe T.Text -> Range -> Range @@ -180,7 +217,7 @@ suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])] -suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..} +suggestFillTypeWildcard Diagnostic{_range=_range,..} -- Foo.hs:3:8: error: -- * Found type wildcard `_' standing for `p -> p1 -> p' @@ -191,7 +228,7 @@ | otherwise = [] suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])] -suggestAddExtension Diagnostic{_range=_range@Range{..},..} +suggestAddExtension Diagnostic{_range=_range,..} -- File.hs:22:8: error: -- Illegal lambda-case (use -XLambdaCase) -- File.hs:22:6: error: @@ -221,7 +258,7 @@ ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])] -suggestModuleTypo Diagnostic{_range=_range@Range{..},..} +suggestModuleTypo Diagnostic{_range=_range,..} -- src/Development/IDE/Core/Compile.hs:58:1: error: -- Could not find module ‘Data.Cha’ -- Perhaps you meant Data.Char (from base-4.12.0.0) @@ -233,7 +270,7 @@ | otherwise = [] suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])] -suggestFillHole Diagnostic{_range=_range@Range{..},..} +suggestFillHole Diagnostic{_range=_range,..} -- ...Development/IDE/LSP/CodeAction.hs:103:9: warning: -- * Found hole: _ :: Int -> String -- * In the expression: _ @@ -268,20 +305,22 @@ | otherwise = [] -suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] -suggestExtendImport contents Diagnostic{_range=_range,..} +suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..} | Just [binding, mod, srcspan] <- matchRegex _message "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$" , Just c <- contents + , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of [s] -> let x = srcSpanToRange s in x{_end = (_end x){_character = succ (_character (_end x))}} _ -> error "bug in srcspan parser" importLine = textInRange range c in [("Add " <> binding <> " to the import list of " <> mod - , [TextEdit range (addBindingToImportList binding importLine)])] + , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])] | otherwise = [] +suggestExtendImport Nothing _ _ = [] suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestFixConstructorImport _ Diagnostic{_range=_range,..} @@ -299,29 +338,103 @@ suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..} - | "Top-level binding with no type signature" `T.isInfixOf` _message = let - signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message - startOfLine = Position (_line _start) 0 - beforeLine = Range startOfLine startOfLine - title = if isQuickFix then "add signature: " <> signature else signature - action = TextEdit beforeLine $ signature <> "\n" - in [(title, [action])] -suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..} - | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let + | _message =~ + ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let signature = removeInitialForAll $ T.takeWhile (\x -> x/='*' && x/='•') $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message - startOfLine = Position (_line _start) (_character _start) + startOfLine = Position (_line _start) startCharacter beforeLine = Range startOfLine startOfLine title = if isQuickFix then "add signature: " <> signature else signature - action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " " + action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " in [(title, [action])] where removeInitialForAll :: T.Text -> T.Text removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty)) | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty)) | otherwise = nm <> ty + startCharacter + | "Polymorphic local binding" `T.isPrefixOf` _message + = _character _start + | otherwise + = 0 + suggestSignature _ _ = [] +------------------------------------------------------------------------------------------------- + +suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] +suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message} + | msg <- unifySpaces _message + , Just name <- extractNotInScopeName msg + , Just insertLine <- case hsmodImports of + [] -> case srcSpanStart $ getLoc (head hsmodDecls) of + RealSrcLoc s -> Just $ srcLocLine s - 1 + _ -> Nothing + _ -> case srcSpanEnd $ getLoc (last hsmodImports) of + RealSrcLoc s -> Just $ srcLocLine s + _ -> Nothing + , insertPos <- Position insertLine 0 + , extendImportSuggestions <- matchRegex msg + "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" + = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")]) + | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions + ] +suggestNewImport _ _ _ = [] + +constructNewImportSuggestions + :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text] +constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd + [ renderNewImport identInfo m + | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap + , canUseIdent thingMissing identInfo + , m `notElem` fromMaybe [] notTheseModules + ] + where + renderNewImport identInfo m + | Just q <- qual = "import qualified " <> m <> " as " <> q + | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")" + + (qual, name) = case T.splitOn "." (notInScope thingMissing) of + [n] -> (Nothing, n) + segments -> (Just (T.concat $ init segments), last segments) + importWhat IdentInfo {parent, rendered} + | Just p <- parent = p <> "(" <> rendered <> ")" + | otherwise = rendered + +canUseIdent :: NotInScope -> IdentInfo -> Bool +canUseIdent NotInScopeDataConstructor{} = isDatacon +canUseIdent _ = const True + +data NotInScope + = NotInScopeDataConstructor T.Text + | NotInScopeTypeConstructorOrClass T.Text + | NotInScopeThing T.Text + deriving Show + +notInScope :: NotInScope -> T.Text +notInScope (NotInScopeDataConstructor t) = t +notInScope (NotInScopeTypeConstructorOrClass t) = t +notInScope (NotInScopeThing t) = t + +extractNotInScopeName :: T.Text -> Maybe NotInScope +extractNotInScopeName x + | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’" + = Just $ NotInScopeDataConstructor name + | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’" + = Just $ NotInScopeTypeConstructorOrClass name + | Just [name] <- matchRegex x "ot in scope: \\(([^‘ ]+)\\)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)" + = Just $ NotInScopeThing name + | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’" + = Just $ NotInScopeThing name + | otherwise + = Nothing + +------------------------------------------------------------------------------------------------- + topOfHoleFitsMarker :: T.Text topOfHoleFitsMarker = #if MIN_GHC_API_VERSION(8,6,0) @@ -332,7 +445,7 @@ mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit mkRenameEdit contents range name = - if fromMaybe False maybeIsInfixFunction + if maybeIsInfixFunction == Just True then TextEdit range ("`" <> name <> "`") else TextEdit range name where @@ -414,7 +527,7 @@ rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l] rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l] -rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l] +rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l] rangesForBinding' b (L l (IEThingWith thing _ inners labels)) | showSDocUnsafe (ppr thing) == b = [l] | otherwise = @@ -444,7 +557,7 @@ Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings Nothing -> Nothing -setHandlersCodeLens :: PartialHandlers +setHandlersCodeLens :: PartialHandlers c setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.codeLensHandler = withResponse RspCodeLens codeLens, LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand @@ -455,51 +568,3 @@ unifySpaces :: T.Text -> T.Text unifySpaces = T.unwords . T.words - --------------------------------------------------------------------------------- - -type PositionIndexedString = [(Position, Char)] - -indexedByPosition :: String -> PositionIndexedString -indexedByPosition = unfoldr f . (Position 0 0,) where - f (_, []) = Nothing - f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest)) - f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest)) - --- | Returns a tuple (before, contents, after) -unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString) -unconsRange Range {..} indexedString = (before, mid, after) - where - (before, rest) = span ((/= _start) . fst) indexedString - (mid, after) = span ((/= _end) . fst) rest - -stripRange :: Range -> PositionIndexedString -> PositionIndexedString -stripRange r s = case unconsRange r s of - (b, _, a) -> b ++ a - -extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range] -extendAllToIncludeCommaIfPossible _ [] = [] -extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr - where - r' = case extendToIncludeCommaIfPossible indexedString r of - [] -> r - r' : _ -> r' - indexedString' = stripRange r' indexedString - --- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas -extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range] -extendToIncludeCommaIfPossible indexedString range = - -- a, |b|, c ===> a|, b|, c - [ range{_start = start'} - | (start', ',') : _ <- [before'] - ] - ++ - -- a, |b|, c ===> a, |b, |c - [ range{_end = end'} - | (_, ',') : rest <- [after'] - , let (end', _) : _ = dropWhile (isSpace . snd) rest - ] - where - (before, _, after) = unconsRange range indexedString - after' = dropWhile (isSpace . snd) after - before' = dropWhile (isSpace . snd) (reverse before) diff --git a/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -0,0 +1,112 @@ +-- | Position indexed streams of characters +module Development.IDE.Plugin.CodeAction.PositionIndexed + ( PositionIndexed + , PositionIndexedString + , indexedByPosition + , indexedByPositionStartingFrom + , extendAllToIncludeCommaIfPossible + , mergeRanges + ) +where + +import Data.Char +import Data.List +import Language.Haskell.LSP.Types + +type PositionIndexed a = [(Position, a)] + +type PositionIndexedString = PositionIndexed Char + +-- | Add position indexing to a String. +-- +-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡ +-- > [ ((0,0),'h') +-- > , ((0,1),'e') +-- > , ((0,2),'y') +-- > , ((0,3),'\n') +-- > , ((1,0),' ') +-- > , ((1,1),'h') +-- > , ((1,2),'o') +-- > ] +indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString +indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where + f (_, []) = Nothing + f (p@(Position l _), '\n' : rest) = + Just ((p, '\n'), (Position (l + 1) 0, rest)) + f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest)) + +-- | Add position indexing to a String. +-- +-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0) +indexedByPosition :: String -> PositionIndexedString +indexedByPosition = indexedByPositionStartingFrom (Position 0 0) + +-- | Returns a tuple (before, contents, after) if the range is present. +-- The range is present only if both its start and end positions are present +unconsRange + :: Range + -> PositionIndexed a + -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a) +unconsRange Range {..} indexedString + | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString + , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest + = Just (before, mid, after) + | otherwise + = Nothing + +-- | Strips out all the positions included in the range. +-- Returns 'Nothing' if the start or end of the range are not included in the input. +stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a) +stripRange r s = case unconsRange r s of + Just (b, _, a) -> Just (b ++ a) + Nothing -> Nothing + +-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input. +-- Assumes input ranges are sorted on the start positions. +mergeRanges :: [Range] -> [Range] +mergeRanges (r : r' : rest) + | + -- r' is contained in r + _end r > _end r' = mergeRanges (r : rest) + | + -- r and r' are overlapping + _end r > _start r' = mergeRanges (r { _end = _end r' } : rest) + + | otherwise = r : mergeRanges (r' : rest) +mergeRanges other = other + +-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas +-- +-- @ +-- a, |b|, c ===> a|, b|, c +-- a, b, |c| ===> a, b|, c| +-- a, |b|, |c| ===> a|, b||, c| +-- @ +extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range] +extendAllToIncludeCommaIfPossible indexedString = + mergeRanges . go indexedString . sortOn _start + where + go _ [] = [] + go input (r : rr) + | r' : _ <- extendToIncludeCommaIfPossible input r + , Just input' <- stripRange r' input + = r' : go input' rr + | otherwise + = go input rr + +extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range] +extendToIncludeCommaIfPossible indexedString range + | Just (before, _, after) <- unconsRange range indexedString + , after' <- dropWhile (isSpace . snd) after + , before' <- dropWhile (isSpace . snd) (reverse before) + = + -- a, |b|, c ===> a|, b|, c + [ range { _start = start' } | (start', ',') : _ <- [before'] ] + ++ + -- a, |b|, c ===> a, |b, |c + [ range { _end = end' } + | (_, ',') : rest <- [after'] + , let (end', _) : _ = dropWhile (isSpace . snd) rest + ] + | otherwise + = [range] diff --git a/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TypeFamilies #-} +module Development.IDE.Plugin.CodeAction.RuleTypes + (PackageExports(..), PackageExportsMap + ,IdentInfo(..) + ,mkIdentInfos + ) where + +import Avail (AvailInfo(..)) +import Data.Hashable (Hashable) +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Text (pack, Text) +import Development.IDE.GHC.Util +import Development.Shake (RuleResult) +import Data.HashMap.Strict (HashMap) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Name +import FieldLabel (flSelector) + +type Identifier = Text +type ModuleName = Text + +data IdentInfo = IdentInfo + { name :: !Identifier + , rendered :: Text + , parent :: !(Maybe Text) + , isDatacon :: !Bool + } + deriving (Eq, Generic, Show) + +instance NFData IdentInfo + +mkIdentInfos :: AvailInfo -> [IdentInfo] +mkIdentInfos (Avail n) = + [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)] +mkIdentInfos (AvailTC parent (n:nn) flds) + -- Following the GHC convention that parent == n if parent is exported + | n == parent + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True + | n <- nn ++ map flSelector flds + ] ++ + [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False] + where + parentP = pack $ prettyPrint parent + +mkIdentInfos (AvailTC _ nn flds) + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True + | n <- nn ++ map flSelector flds + ] + +-- Rule type for caching Package Exports +type instance RuleResult PackageExports = PackageExportsMap +type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)] + +newtype PackageExports = PackageExports HscEnvEq + deriving (Eq, Show, Typeable, Generic) + +instance Hashable PackageExports +instance NFData PackageExports +instance Binary PackageExports diff --git a/src/Development/IDE/Plugin/CodeAction/Rules.hs b/src/Development/IDE/Plugin/CodeAction/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Plugin/CodeAction/Rules.hs @@ -0,0 +1,61 @@ +module Development.IDE.Plugin.CodeAction.Rules + ( rulePackageExports + ) +where + +import Data.HashMap.Strict ( fromListWith ) +import Data.Text ( Text + , pack + ) +import Data.Traversable ( forM ) +import Development.IDE.Core.Rules +import Development.IDE.GHC.Util +import Development.IDE.Plugin.CodeAction.RuleTypes +import Development.Shake +import GHC ( DynFlags(pkgState) ) +import HscTypes ( IfaceExport + , hsc_dflags + , mi_exports + ) +import LoadIface +import Maybes +import Module ( Module(..) + , ModuleName + , moduleNameString + ) +import Packages ( explicitPackages + , exposedModules + , packageConfigId + ) +import TcRnMonad ( WhereFrom(ImportByUser) + , initIfaceLoad + ) + +rulePackageExports :: Rules () +rulePackageExports = defineNoFile $ \(PackageExports session) -> do + let env = hscEnv session + pkgst = pkgState (hsc_dflags env) + depends = explicitPackages pkgst + targets = + [ (pkg, mn) + | d <- depends + , Just pkg <- [lookupPackageConfig d env] + , (mn, _) <- exposedModules pkg + ] + + results <- forM targets $ \(pkg, mn) -> do + modIface <- liftIO $ initIfaceLoad env $ loadInterface + "" + (Module (packageConfigId pkg) mn) + (ImportByUser False) + case modIface of + Failed _err -> return mempty + Succeeded mi -> do + let avails = mi_exports mi + return $ concatMap (unpackAvail mn) avails + return $ fromListWith (++) $ concat results + +unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])] +unpackAvail mod = + map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)])) + . mkIdentInfos diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +#include "ghc-api-version.h" module Development.IDE.Plugin.Completions(plugin) where +import Control.Applicative import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Core as LSP @@ -10,8 +13,6 @@ import Development.Shake.Classes import Development.Shake import GHC.Generics -import Data.Maybe -import HscTypes import Development.IDE.Plugin import Development.IDE.Core.Service @@ -22,29 +23,39 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Util import Development.IDE.LSP.Server -import Development.IDE.Import.DependencyInformation +#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB) +import Data.Maybe +import Development.IDE.Import.DependencyInformation +#endif -plugin :: Plugin +plugin :: Plugin c plugin = Plugin produceCompletions setHandlersCompletion produceCompletions :: Rules () produceCompletions = define $ \ProduceCompletions file -> do - deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file - tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps) + +-- When possible, rely on the haddocks embedded in our interface files +-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' +#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) + let parsedDeps = [] +#else + deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file + parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps) +#endif tm <- fmap fst <$> useWithStale TypeCheck file packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file case (tm, packageState) of (Just tm', Just packageState') -> do - cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState') - (tmrModule tm') (map tmrModule tms) - return ([], Just (cdata, tm')) + cdata <- liftIO $ cacheDataProducer packageState' + (tmrModule tm') parsedDeps + return ([], Just cdata) _ -> return ([], Nothing) -- | Produce completions info for a file -type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult) +type instance RuleResult ProduceCompletions = CachedCompletions data ProduceCompletions = ProduceCompletions deriving (Eq, Show, Typeable, Generic) @@ -55,7 +66,7 @@ -- | Generate code actions. getCompletionsLSP - :: LSP.LspFuncs () + :: LSP.LspFuncs c -> IdeState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult) @@ -66,23 +77,27 @@ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do - let npath = toNormalizedFilePath path - (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath) + let npath = toNormalizedFilePath' path + (ideOpts, compls) <- runAction ide $ do + opts <- getIdeOptions + compls <- useWithStale ProduceCompletions npath + pm <- useWithStale GetParsedModule npath + pure (opts, liftA2 (,) compls pm) case compls of - Just ((cci', tm'), mapping) -> do - let position' = fromCurrentPosition mapping position + Just ((cci', _), (pm, mapping)) -> do + let !position' = fromCurrentPosition mapping position pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position' case (pfix, completionContext) of (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (Completions $ List []) (Just pfix', _) -> do let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing - Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True) + Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True) _ -> return (Completions $ List []) _ -> return (Completions $ List []) _ -> return (Completions $ List []) -setHandlersCompletion :: PartialHandlers +setHandlersCompletion :: PartialHandlers c setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{ LSP.completionHandler = withResponse RspCompletion getCompletionsLSP } diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +#include "ghc-api-version.h" -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( CachedCompletions @@ -10,7 +11,7 @@ import Control.Applicative import Data.Char (isSpace, isUpper) import Data.Generics -import Data.List as List hiding (stripPrefix) +import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Text as T @@ -25,6 +26,12 @@ import Var import Packages import DynFlags +#if MIN_GHC_API_VERSION(8,10,0) +import Predicate (isDictTy) +import GHC.Platform +import Pair +import Coercion +#endif import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities @@ -125,7 +132,7 @@ mkCompl :: IdeOptions -> CompItem -> CompletionItem mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} = - CompletionItem label kind ((colon <>) <$> typeText) + CompletionItem label kind (List []) ((colon <>) <$> typeText) (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs') Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing @@ -155,7 +162,7 @@ where argTypes = getArgs typ argText :: T.Text - argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes + argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes snippet :: Int -> Type -> T.Text snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}" getArgs :: Type -> [Type] @@ -169,38 +176,44 @@ then getArgs ret else Prelude.filter (not . isDictTy) args | isPiTy t = getArgs $ snd (splitPiTys t) +#if MIN_GHC_API_VERSION(8,10,0) + | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t + = getArgs t +#else | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t) +#endif | otherwise = [] mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label (Just CiModule) Nothing + CompletionItem label (Just CiModule) (List []) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) (Just label) + CompletionItem m (Just CiModule) (List []) (Just label) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - where + where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing + CompletionItem label (Just CiKeyword) (List []) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkPragmaCompl :: T.Text -> T.Text -> CompletionItem mkPragmaCompl label insertText = - CompletionItem label (Just CiKeyword) Nothing + CompletionItem label (Just CiKeyword) (List []) Nothing Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions -cacheDataProducer packageState dflags tm tcs = do +cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions +cacheDataProducer packageState tm deps = do let parsedMod = tm_parsed_module tm + dflags = hsc_dflags packageState curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod Just (_,limports,_,_) = tm_renamed_source tm @@ -257,18 +270,18 @@ let typ = Just $ varType var name = Var.varName var label = T.pack $ showGhc name - docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name + docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name return $ CI name (showModName curMod) typ label Nothing docs toCompItem :: ModuleName -> Name -> IO CompItem toCompItem mn n = do - docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n + docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n -- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi -- and leads to fun errors like "Cannot continue after interface file error". #ifdef GHC_LIB let ty = Right Nothing #else - ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do + ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do name' <- lookupName n return $ name' >>= safeTyThingType #endif @@ -291,19 +304,16 @@ | otherwise = x { _insertTextFormat = Just PlainText , _insertText = Nothing } - where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) -- | Returns the cached completions for the given module and position. -getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem] +getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem] getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules } - tm prefixInfo caps withSnippets = do + pm prefixInfo caps withSnippets = do let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." fullPrefix = enteredQual <> prefixText - -- default to value context if no explicit context - context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm) - {- correct the position by moving 'foo :: Int -> String -> ' ^ to 'foo :: Int -> String -> ' @@ -332,10 +342,11 @@ where isTypeCompl = isTcOcc . occName . origName -- completions specific to the current context - ctxCompls' = case context of - TypeContext -> filter isTypeCompl compls - ValueContext -> filter (not . isTypeCompl) compls - _ -> filter (not . isTypeCompl) compls + ctxCompls' = case getCContext pos pm of + Nothing -> compls + Just TypeContext -> filter isTypeCompl compls + Just ValueContext -> filter (not . isTypeCompl) compls + Just _ -> filter (not . isTypeCompl) compls -- Add whether the text to insert has backticks ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' @@ -361,7 +372,9 @@ filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas filtOptsCompls = filtListWith mkExtCompl - filtKeywordCompls = if T.null prefixModule then filtListWith mkExtCompl keywords else [] + filtKeywordCompls + | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | otherwise = [] stripLeading :: Char -> String -> String stripLeading _ [] = [] @@ -382,13 +395,17 @@ = filtModNameCompls ++ map (toggleSnippets caps withSnippets . mkCompl ideOpts . stripAutoGenerated) filtCompls ++ filtKeywordCompls - + return result -- The supported languages and extensions languagesAndExts :: [T.Text] +#if MIN_GHC_API_VERSION(8,10,0) +languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown ) +#else languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions - +#endif + -- --------------------------------------------------------------------- -- helper functions for pragmas -- --------------------------------------------------------------------- @@ -510,25 +527,4 @@ , "$t" , "$c" , "$m" - ] - -keywords :: [T.Text] -keywords = - [ - -- From https://wiki.haskell.org/Keywords - "as" - , "case", "of" - , "class", "instance", "type" - , "data", "family", "newtype" - , "default" - , "deriving" - , "do", "mdo", "proc", "rec" - , "forall" - , "foreign" - , "hiding" - , "if", "then", "else" - , "import", "qualified", "hiding" - , "infix", "infixl", "infixr" - , "let", "in", "where" - , "module" ] diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -13,15 +13,12 @@ import Development.IDE.Types.Location -- DAML compiler and infrastructure -import Development.Shake -import Development.IDE.GHC.Util import Development.IDE.GHC.Compat import Development.IDE.Types.Options import Development.IDE.Spans.Type as SpanInfo import Development.IDE.Spans.Common (spanDocToMarkdown) -- GHC API imports -import Avail import DynFlags import FastString import Name @@ -40,14 +37,13 @@ -- | Locate the definition of the name at a given position. gotoDefinition :: MonadIO m - => (FilePath -> m (Maybe HieFile)) + => (Module -> m (Maybe (HieFile, FilePath))) -> IdeOptions - -> HscEnv -> [SpanInfo] -> Position -> m (Maybe Location) -gotoDefinition getHieFile ideOpts pkgState srcSpans pos = - listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans +gotoDefinition getHieFile ideOpts srcSpans pos = + listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans -- | Synopsis for the name at a given position. atPoint @@ -87,7 +83,7 @@ constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts constraintsT = T.intercalate ", " (map showName constraintsOverFVs) - typeAnnotation = case constraintsOverFVs of + typeAnnotation = case constraintsOverFVs of [] -> colon <> showName typ [_] -> colon <> constraintsT <> "\n=> " <> showName typ _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ @@ -119,8 +115,15 @@ Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"] Nothing -> False -locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location] -locationsAtPoint getHieFile IdeOptions{..} pkgState pos = +locationsAtPoint + :: forall m + . MonadIO m + => (Module -> m (Maybe (HieFile, FilePath))) + -> IdeOptions + -> Position + -> [SpanInfo] + -> m [Location] +locationsAtPoint getHieFile _ideOptions pos = fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos where getSpan :: SpanSource -> m (Maybe SrcSpan) getSpan NoSource = pure Nothing @@ -130,20 +133,16 @@ sp@(RealSrcSpan _) -> pure $ Just sp sp@(UnhelpfulSpan _) -> runMaybeT $ do guard (sp /= wiredInSrcSpan) - -- This case usually arises when the definition is in an external package. + -- This case usually arises when the definition is in an external package (DAML only). -- 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 - let unitId = moduleUnitId mod - pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState - hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod - hieFile <- MaybeT $ getHieFile hiePath - avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile) - srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod + (hieFile, srcPath) <- MaybeT $ 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 $ nameSrcSpan $ availName avail + let span = setFileName srcPath $ fst avail pure span -- We ignore uniques and source spans and only compare the name and the module. eqName :: Name -> Name -> Bool diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -20,6 +20,7 @@ import Desugar import GHC import GhcMonad +import HscTypes import FastString (mkFastString) import OccName import Development.IDE.Types.Location @@ -49,28 +50,36 @@ -- | Get source span info, used for e.g. AtPoint and Goto Definition. getSrcSpanInfos :: HscEnv - -> [(Located ModuleName, Maybe NormalizedFilePath)] + -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order -> TcModuleResult - -> [TcModuleResult] + -> [ParsedModule] -- ^ Dependencies parsed, optional + -> [ModIface] -- ^ Dependencies module interfaces, required -> IO SpansInfo -getSrcSpanInfos env imports tc tms = - runGhcEnv env $ - getSpanInfo imports (tmrModule tc) (map tmrModule tms) +getSrcSpanInfos env imports tc parsedDeps deps = + evalGhcEnv env $ + getSpanInfo imports (tmrModule tc) parsedDeps deps -- | Get ALL source spans in the module. getSpanInfo :: GhcMonad m => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports -> TypecheckedModule - -> [TypecheckedModule] + -> [ParsedModule] + -> [ModIface] -> m SpansInfo -getSpanInfo mods tcm tcms = - do let tcs = tm_typechecked_source tcm +getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps = + do let tcs = tm_typechecked_source bs = listifyAllSpans tcs :: [LHsBind GhcTc] es = listifyAllSpans tcs :: [LHsExpr GhcTc] ps = listifyAllSpans' tcs :: [Pat GhcTc] - ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn] - allModules = tcm:tcms - funBinds = funBindMap $ tm_parsed_module tcm + ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn] + allModules = tm_parsed_module : parsedDeps + funBinds = funBindMap tm_parsed_module + + -- Load all modules in HPT to make their interface documentation available + mapM_ (`loadDepModule` Nothing) (reverse deps) + forM_ (modInfoIface tm_checked_module_info) $ \modIface -> + modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing) + bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds ets <- mapM (getTypeLHsExpr allModules) es -- expressions pts <- mapM (getTypeLPat allModules) ps -- patterns @@ -117,19 +126,19 @@ -- | Get the name and type of a binding. getTypeLHsBind :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> OccEnv (HsBind GhcPs) -> LHsBind GhcTc -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid}) +getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid}) | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc tms name + docs <- getDocumentationTryGhc deps name return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. -getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do +getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do let name = getName (unLoc pid) - docs <- getDocumentationTryGhc tms name + docs <- getDocumentationTryGhc deps name return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)] getTypeLHsBind _ _ _ = return [] @@ -142,17 +151,17 @@ -- | Get the name and type of an expression. getTypeLHsExpr :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> LHsExpr GhcTc -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLHsExpr tms e = do +getTypeLHsExpr deps e = do hs_env <- getSession (_, mbe) <- liftIO (deSugarExpr hs_env e) case mbe of Just expr -> do let ss = getSpanSource (unLoc e) docs <- case ss of - Named n -> getDocumentationTryGhc tms n + Named n -> getDocumentationTryGhc deps n _ -> return emptySpanDoc return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs) Nothing -> return Nothing @@ -198,13 +207,13 @@ -- | Get the name and type of a pattern. getTypeLPat :: (GhcMonad m) - => [TypecheckedModule] + => [ParsedModule] -> Pat GhcTc -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc)) -getTypeLPat tms pat = do +getTypeLPat deps pat = do let (src, spn) = getSpanSource pat docs <- case src of - Named n -> getDocumentationTryGhc tms n + Named n -> getDocumentationTryGhc deps n _ -> return emptySpanDoc return $ Just (src, spn, Just (hsPatType pat), docs) where @@ -216,12 +225,12 @@ getLHsType :: GhcMonad m - => [TypecheckedModule] + => [ParsedModule] -> LHsType GhcRn -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)] -getLHsType tms (L spn (HsTyVar U _ v)) = do +getLHsType deps (L spn (HsTyVar U _ v)) = do let n = unLoc v - docs <- getDocumentationTryGhc tms n + docs <- getDocumentationTryGhc deps n #ifdef GHC_LIB let ty = Right Nothing #else diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -18,6 +18,7 @@ import Data.Data import qualified Data.Generics import qualified Data.Text as T +import Data.List.Extra import GHC import Outputable @@ -28,7 +29,6 @@ import Var #endif -import Data.Char (isSpace) import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H @@ -135,9 +135,9 @@ = replicate level '#' ++ " " ++ haddockToMarkdown title haddockToMarkdown (H.DocUnorderedList things) - = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things) + = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things) haddockToMarkdown (H.DocOrderedList things) - = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things) + = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things) haddockToMarkdown (H.DocDefList things) = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) @@ -159,4 +159,4 @@ splitForList s = case lines s of [] -> "" - (first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest + (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -14,33 +14,33 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Spans.Common import FastString -import GHC import SrcLoc getDocumentationTryGhc :: GhcMonad m - => [TypecheckedModule] + => [ParsedModule] -> Name -> m SpanDoc -- getDocs goes through the GHCi codepaths which cause problems on ghc-lib. -- See https://github.com/digital-asset/daml/issues/4152 for more details. #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB) -getDocumentationTryGhc tcs name = do +getDocumentationTryGhc sources name = do res <- catchSrcErrors "docs" $ getDocs name case res of Right (Right (Just docs, _)) -> return $ SpanDocString docs - _ -> return $ SpanDocText $ getDocumentation tcs name + _ -> return $ SpanDocText $ getDocumentation sources name #else -getDocumentationTryGhc tcs name = do - return $ SpanDocText $ getDocumentation tcs name +getDocumentationTryGhc sources name = do + return $ SpanDocText $ getDocumentation sources name #endif getDocumentation - :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in. + :: [ParsedModule] -- ^ All of the possible modules it could be defined in. -> Name -- ^ The name you want documentation for. -> [T.Text] -- This finds any documentation between the name you want @@ -50,16 +50,18 @@ -- may be edge cases where it is very wrong). -- TODO : Build a version of GHC exactprint to extract this information -- more accurately. -getDocumentation tcs targetName = fromMaybe [] $ do +getDocumentation sources targetName = fromMaybe [] $ do -- Find the module the target is defined in. targetNameSpan <- realSpan $ nameSrcSpan targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse tcs -- TODO : Is reversing the list here really neccessary? - -- Names bound by the module (we want to exclude non-"top-level" - -- bindings but unfortunately we get all here). - let bs = mapMaybe name_of_bind - (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc]) + $ reverse sources -- TODO : Is reversing the list here really neccessary? + + -- Top level names bound by the module + let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc + , L _ (ValD hsbind) <- hsmodDecls + , Just n <- [name_of_bind hsbind] + ] -- Sort the names' source spans. let sortedSpans = sortedNameSpans bs -- Now go ahead and extract the docs. @@ -81,16 +83,16 @@ where -- Get the name bound by a binding. We only concern ourselves with -- @FunBind@ (which covers functions and variables). - name_of_bind :: LHsBind GhcTc -> Maybe Name - name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id)) + name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) + name_of_bind FunBind {fun_id} = Just fun_id name_of_bind _ = Nothing -- Get source spans from names, discard unhelpful spans, remove -- duplicates and sort. - sortedNameSpans :: [Name] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls) + sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] + sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after - ann = snd . pm_annotations . tm_parsed_module - annotationFileName :: TypecheckedModule -> Maybe FastString + ann = snd . pm_annotations + annotationFileName :: ParsedModule -> Maybe FastString annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] realSpans = diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -6,10 +6,12 @@ LSP.Diagnostic(..), ShowDiagnostic(..), FileDiagnostic, + IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, List(..), ideErrorText, + ideErrorWithSource, showDiagnostics, showDiagnosticsColored, ) where @@ -18,7 +20,7 @@ import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc -import Language.Haskell.LSP.Types as LSP ( +import Language.Haskell.LSP.Types as LSP (DiagnosticSource, DiagnosticSeverity(..) , Diagnostic(..) , List(..) @@ -30,15 +32,27 @@ import Development.IDE.Types.Location +-- A rule on a file should only return diagnostics for that given file. It should +-- not propagate diagnostic errors through multiple phases. +type IdeResult v = ([FileDiagnostic], Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic { +ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) + +ideErrorWithSource + :: Maybe DiagnosticSource + -> Maybe DiagnosticSeverity + -> a + -> T.Text + -> (a, ShowDiagnostic, Diagnostic) +ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { _range = noRange, - _severity = Just LSP.DsError, + _severity = sev, _code = Nothing, - _source = Just "compiler", + _source = source, _message = msg, - _relatedInformation = Nothing + _relatedInformation = Nothing, + _tags = Nothing }) -- | Defines whether a particular diagnostic should be reported diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -10,15 +10,16 @@ , Position(..) , showPosition , Range(..) - , Uri(..) - , NormalizedUri + , LSP.Uri(..) + , LSP.NormalizedUri , LSP.toNormalizedUri , LSP.fromNormalizedUri - , NormalizedFilePath + , LSP.NormalizedFilePath , fromUri - , toNormalizedFilePath - , fromNormalizedFilePath - , filePathToUri + , emptyFilePath + , emptyPathUri + , toNormalizedFilePath' + , LSP.fromNormalizedFilePath , filePathToUri' , uriToFilePath' , readSrcSpan @@ -26,134 +27,42 @@ import Control.Applicative import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..)) -import Control.DeepSeq import Control.Monad -import Data.Binary -import Data.Maybe as Maybe -import Data.Hashable +import Data.Hashable (Hashable(hash)) import Data.String -import qualified Data.Text as T import FastString -import Network.URI -import System.FilePath -import qualified System.FilePath.Posix as FPP -import qualified System.FilePath.Windows as FPW -import System.Info.Extra import qualified Language.Haskell.LSP.Types as LSP -import Language.Haskell.LSP.Types as LSP ( - filePathToUri - , NormalizedUri(..) - , Uri(..) - , toNormalizedUri - , fromNormalizedUri - ) import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP -import GHC.Generics - - --- | Newtype wrapper around FilePath that always has normalized slashes. --- The NormalizedUri and hash of the FilePath are cached to avoided --- repeated normalisation when we need to compute them (which is a lot). --- --- This is one of the most performance critical parts of ghcide, do not --- modify it without profiling. -data NormalizedFilePath = NormalizedFilePath NormalizedUriWrapper !Int !FilePath - deriving (Generic, Eq, Ord) - -instance NFData NormalizedFilePath where -instance Binary NormalizedFilePath where - put (NormalizedFilePath _ _ fp) = put fp - get = do - v <- Data.Binary.get :: Get FilePath - return (toNormalizedFilePath v) - - -instance Show NormalizedFilePath where - show (NormalizedFilePath _ _ fp) = "NormalizedFilePath " ++ show fp - -instance Hashable NormalizedFilePath where - hash (NormalizedFilePath _ h _) = h - --- Just to define NFData and Binary -newtype NormalizedUriWrapper = - NormalizedUriWrapper { unwrapNormalizedFilePath :: NormalizedUri } - deriving (Show, Generic, Eq, Ord) - -instance NFData NormalizedUriWrapper where - rnf = rwhnf - - -instance Hashable NormalizedUriWrapper where - -instance IsString NormalizedFilePath where - fromString = toNormalizedFilePath +import Data.Maybe (fromMaybe) -toNormalizedFilePath :: FilePath -> NormalizedFilePath +toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "." -toNormalizedFilePath "" = NormalizedFilePath (NormalizedUriWrapper emptyPathUri) (hash ("" :: String)) "" -toNormalizedFilePath fp = - let nfp = normalise fp - in NormalizedFilePath (NormalizedUriWrapper $ filePathToUriInternal' nfp) (hash nfp) nfp +toNormalizedFilePath' "" = emptyFilePath +toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp -fromNormalizedFilePath :: NormalizedFilePath -> FilePath -fromNormalizedFilePath (NormalizedFilePath _ _ fp) = fp +emptyFilePath :: LSP.NormalizedFilePath +emptyFilePath = LSP.NormalizedFilePath emptyPathUri "" -- | We use an empty string as a filepath when we don’t have a file. -- However, haskell-lsp doesn’t support that in uriToFilePath and given -- that it is not a valid filepath it does not make sense to upstream a fix. -- So we have our own wrapper here that supports empty filepaths. -uriToFilePath' :: Uri -> Maybe FilePath +uriToFilePath' :: LSP.Uri -> Maybe FilePath uriToFilePath' uri - | uri == fromNormalizedUri emptyPathUri = Just "" + | uri == LSP.fromNormalizedUri emptyPathUri = Just "" | otherwise = LSP.uriToFilePath uri -emptyPathUri :: NormalizedUri -emptyPathUri = filePathToUriInternal' "" - -filePathToUri' :: NormalizedFilePath -> NormalizedUri -filePathToUri' (NormalizedFilePath (NormalizedUriWrapper u) _ _) = u - -filePathToUriInternal' :: FilePath -> NormalizedUri -filePathToUriInternal' fp = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp - where - -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that - -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost. - - toNormalizedUri :: Uri -> NormalizedUri - toNormalizedUri (Uri t) = - NormalizedUri $ T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t - - platformAdjustToUriPath :: FilePath -> String - platformAdjustToUriPath srcPath - | isWindows = '/' : escapedPath - | otherwise = escapedPath - where - (splitDirectories, splitDrive) - | isWindows = - (FPW.splitDirectories, FPW.splitDrive) - | otherwise = - (FPP.splitDirectories, FPP.splitDrive) - escapedPath = - case splitDrive srcPath of - (drv, rest) -> - convertDrive drv `FPP.joinDrive` - FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest) - -- splitDirectories does not remove the path separator after the drive so - -- we do a final replacement of \ to / - convertDrive drv - | isWindows && FPW.hasTrailingPathSeparator drv = - FPP.addTrailingPathSeparator (init drv) - | otherwise = drv - unescaped c - | isWindows = isUnreserved c || c `elem` [':', '\\', '/'] - | otherwise = isUnreserved c || c == '/' - - +emptyPathUri :: LSP.NormalizedUri +emptyPathUri = + let s = "file://" + in LSP.NormalizedUri (hash s) s -fromUri :: LSP.NormalizedUri -> NormalizedFilePath -fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri +filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri +filePathToUri' = LSP.normalizedFilePathToUri +fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath +fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath noFilePath :: FilePath noFilePath = "" diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -12,25 +12,25 @@ , clientSupportsProgress , IdePkgLocationOptions(..) , defaultIdeOptions + , IdeResult ) where -import Data.Maybe import Development.Shake import Development.IDE.GHC.Util import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) import qualified Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Data.Text as T +import Development.IDE.Types.Diagnostics data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings -- and a list of errors, along with a new parse tree. - , optGhcSession :: IO (FilePath -> Action HscEnvEq) + , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq)) -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@. - -- The 'IO' will be called once, then the resulting function will be applied once per file. + -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file. -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work. - -- You should not use 'newCacheIO' to get that caching, because of - -- https://github.com/ndmitchell/shake/issues/725. , optPkgLocationOpts :: IdePkgLocationOptions -- ^ How to locate source and @.hie@ files given a module name. , optExtensions :: [String] @@ -43,12 +43,17 @@ -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds. , optShakeProfiling :: Maybe FilePath -- ^ Set to 'Just' to create a directory of profiling reports. + , optTesting :: Bool + -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations. , optLanguageSyntax :: String -- ^ the ```language to use , optNewColonConvention :: Bool -- ^ whether to use new colon convention + , optKeywords :: [T.Text] + -- ^ keywords used for completions. These are customizable + -- since DAML has a different set of keywords than Haskell. , optDefer :: IdeDefer -- ^ Whether to defer type errors, typed holes and out of scope -- variables. Deferral allows the IDE to continue to provide @@ -70,10 +75,10 @@ newtype IdeDefer = IdeDefer Bool clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress -clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $ - LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities) +clientSupportsProgress caps = IdeReportProgress $ Just True == + (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) -defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions +defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions defaultIdeOptions session = IdeOptions {optPreprocessor = IdePreprocessedSource [] [] ,optGhcSession = session @@ -85,7 +90,9 @@ ,optReportProgress = IdeReportProgress False ,optLanguageSyntax = "haskell" ,optNewColonConvention = False + ,optKeywords = haskellKeywords ,optDefer = IdeDefer True + ,optTesting = False } @@ -103,3 +110,23 @@ defaultIdePkgLocationOptions :: IdePkgLocationOptions defaultIdePkgLocationOptions = IdePkgLocationOptions f f where f _ _ = return Nothing + +-- | From https://wiki.haskell.org/Keywords +haskellKeywords :: [T.Text] +haskellKeywords = + [ "as" + , "case", "of" + , "class", "instance", "type" + , "data", "family", "newtype" + , "default" + , "deriving" + , "do", "mdo", "proc", "rec" + , "forall" + , "foreign" + , "hiding" + , "if", "then", "else" + , "import", "qualified", "hiding" + , "infix", "infixl", "infixr" + , "let", "in", "where" + , "module" + ] diff --git a/test/data/GotoHover.hs b/test/data/GotoHover.hs deleted file mode 100644 --- a/test/data/GotoHover.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- HLINT ignore -} -module Testing ( module Testing ) where -import Data.Text (Text, pack) -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined where - - inner :: Char - inner = undefined diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/Bar.hs @@ -0,0 +1,3 @@ +module Bar (Bar(..)) where + +data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/Foo.hs @@ -0,0 +1,5 @@ +module Foo (Bar, foo) where + +import Bar + +foo = Bar diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs new file mode 100644 --- /dev/null +++ b/test/data/hover/GotoHover.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{- HLINT ignore -} +module Testing ( module Testing ) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo diff --git a/test/data/multi/a/A.hs b/test/data/multi/a/A.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where + +foo = () diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal new file mode 100644 --- /dev/null +++ b/test/data/multi/a/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: A + hs-source-dirs: . diff --git a/test/data/multi/b/B.hs b/test/data/multi/b/B.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/test/data/multi/b/b.cabal b/test/data/multi/b/b.cabal new file mode 100644 --- /dev/null +++ b/test/data/multi/b/b.cabal @@ -0,0 +1,9 @@ +name: b +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: B + hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project new file mode 100644 --- /dev/null +++ b/test/data/multi/cabal.project @@ -0,0 +1,1 @@ +packages: a b diff --git a/test/data/multi/hie.yaml b/test/data/multi/hie.yaml new file mode 100644 --- /dev/null +++ b/test/data/multi/hie.yaml @@ -0,0 +1,6 @@ +cradle: + cabal: + - path: "./a" + component: "lib:a" + - path: "./b" + component: "lib:b" diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1,1964 +1,2496 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} -#include "ghc-api-version.h" - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Exception (catch) -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Data.Char (toLower) -import Data.Foldable -import Data.List -import Data.Rope.UTF16 (Rope) -import qualified Data.Rope.UTF16 as Rope -import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) -import Development.IDE.GHC.Util -import qualified Data.Text as T -import Development.IDE.Spans.Common -import Development.IDE.Test -import Development.IDE.Test.Runfiles -import Development.IDE.Types.Location -import qualified Language.Haskell.LSP.Test as LSPTest -import Language.Haskell.LSP.Test hiding (openDoc') -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.VFS (applyChange) -import System.Environment.Blank (setEnv) -import System.FilePath -import System.IO.Extra -import System.Directory -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Data.Maybe - -main :: IO () -main = defaultMain $ testGroup "HIE" - [ testSession "open close" $ do - doc <- openDoc' "Testing.hs" "haskell" "" - void (message :: Session WorkDoneProgressCreateRequest) - void (message :: Session WorkDoneProgressBeginNotification) - closeDoc doc - void (message :: Session WorkDoneProgressEndNotification) - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeActionTests - , codeLensesTests - , outlineTests - , findDefinitionAndHoverTests - , pluginTests - , preprocessorTests - , thTests - , unitTests - , haddockTests - , positionMappingTests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO InitializeResponse -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just True) - , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just True) - , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False) - , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False) - , chk "NO find references" _referencesProvider Nothing - , chk "NO doc highlight" _documentHighlightProvider Nothing - , chk " doc symbol" _documentSymbolProvider (Just True) - , chk "NO workspace symbol" _workspaceSymbolProvider Nothing - , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True - , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing - , chk "NO doc formatting" _documentFormattingProvider Nothing - , chk "NO doc range formatting" - _documentRangeFormattingProvider Nothing - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) - , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) - , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"]) - , chk "NO workspace" _workspace nothingWorkspace - , chk "NO experimental" _experimental Nothing - ] where - - tds = Just (TDSOptions (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (SaveOptions {_includeText = Nothing})})) - - nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing}) - - chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner - innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c - innerCaps _ = error "this test only expects inner capabilities" - - acquire :: IO InitializeResponse - acquire = run initializeResponse - - release :: InitializeResponse -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- openDoc' "Testing.hs" "haskell" content - void (message :: Session WorkDoneProgressCreateRequest) - void (message :: Session WorkDoneProgressBeginNotification) - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar a b = cd + b" - ] - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DsError, (2, 14), "Variable not in scope: ab") - , (DsError, (4, 10), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- openDoc' "A.hs" "haskell" $ sourceA binding - _ <- openDoc' "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - , deferralTest "message shows error" "True" "A.hs:3:5: error:" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- openDoc' "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- openDoc' "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- openDoc' "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- openDoc' "ModuleA.hs" "haskell" contentA - _ <- openDoc' "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- openDoc' "ModuleA.hs" "haskell" contentA - _ <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- openDoc' "ModuleA.hs" "haskell" contentA - _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot - _ <- openDoc' "ModuleC.hs" "haskell" contentC - expectDiagnostics [] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- openDoc' "ModuleA.hs" "haskell" contentA - _ <- openDoc' "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] - ) - ] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - ] - _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent - _ <- openDoc' "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo a = 1" - ] - _ <- openDoc' "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DsWarning, (2, 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (map toLower drive ) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (map toLower drive ) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA) - diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification - let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg = _message (head (toList diags) :: Diagnostic) - liftIO $ unless ("redundant" `T.isInfixOf` msg) $ - assertFailure ("Expected redundant import but got " <> T.unpack msg) - closeDoc a - ] - -codeActionTests :: TestTree -codeActionTests = testGroup "code actions" - [ renameActionTests - , typeWildCardActionTests - , removeImportTests - , extendImportTests - , addExtensionTests - , fixConstructorImportTests - , importRenameActionTests - , fillTypedHoleTests - , addSigActionTests - , insertNewDefinitionTests - ] - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -renameActionTests :: TestTree -renameActionTests = testGroup "rename actions" - [ testSession "change to local variable name" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argNme" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "foo :: Int -> Int" - , "foo argName = argName" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "change to name of imported function" $ do - let content = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybToList" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" - executeCodeAction action - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data.Maybe (maybeToList)" - , "foo :: Maybe a -> [a]" - , "foo = maybeToList" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "suggest multiple local variable names" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Char -> Char -> Char -> Char" - , "foo argument1 argument2 argument3 = argumentX" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) - ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] - return() - , testSession "change infix function" $ do - let content = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monnus` y" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) - [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] - executeCodeAction fixTypo - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "monus :: Int -> Int" - , "monus x y = max 0 (x - y)" - , "foo x y = x `monus` y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -typeWildCardActionTests :: TestTree -typeWildCardActionTests = testGroup "type wildcard actions" - [ testSession "global signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x = x" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (p -> p)" - , "func x = x" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "multi-line message" $ do - let content = T.unlines - [ "module Testing where" - , "func :: _" - , "func x y = x + y" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: (Integer -> Integer -> Integer)" - , "func x y = x + y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "local signature" $ do - let content = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: _" - , " y = x * 2" - , " in y" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) - let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands - , "Use type signature" `T.isInfixOf` actionTitle - ] - executeCodeAction addSignature - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "func :: Int -> Int" - , "func x =" - , " let y :: (Int)" - , " y = x * 2" - , " in y" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -removeImportTests :: TestTree -removeImportTests = testGroup "remove import actions" - [ testSession "redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "qualified redundant" $ do - let contentA = T.unlines - [ "module ModuleA where" - ] - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA" - , "stuffB :: Integer" - , "stuffB = 123" - ] - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "stuffB :: Integer" - , "stuffB = 123" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant binding" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "stuffA = False" - , "stuffB :: Integer" - , "stuffB = 123" - , "stuffC = ()" - ] - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" - , "main = print stuffB" - ] - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , testSession "redundant symbol binding" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "a !! b = a" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A ((!!), stuffB, (!!))" - , "main = print A.stuffB" - ] - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) -#if MIN_GHC_API_VERSION(8,6,0) - liftIO $ "Remove !! from import" @=? actionTitle -#else - liftIO $ "Remove A.!! from import" @=? actionTitle -#endif - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print A.stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "data A = A" - , "stuffB :: Integer" - , "stuffB = 123" - ] - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (A(..), stuffB)" - , "main = print stuffB" - ] - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - [CACodeAction action@CodeAction { _title = actionTitle }] - <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) - liftIO $ "Remove A from import" @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - let expectedContentAfterAction = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA (stuffB)" - , "main = print stuffB" - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - ] - -extendImportTests :: TestTree -extendImportTests = testGroup "extend import actions" - [ testSession "extend single line import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffB)" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - "Add stuffA to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import ModuleA as A (stuffA, stuffB)" - , "main = print (stuffA, stuffB)" - ]) - , testSession "extend single line import with type" $ template - (T.unlines - [ "module ModuleA where" - , "type A = Double" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - , "b :: A" - , "b = 0" - ]) - (Range (Position 2 5) (Position 2 5)) - "Add A to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = 0" - ]) - , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A)" - , "b :: A" - , "b = Constructor" - ]) - (Range (Position 2 5) (Position 2 5)) - "Add Constructor to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import ModuleA (A(Constructor))" - , "b :: A" - , "b = Constructor" - ]) - , testSession "extend single line qualified import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - "Add stuffA to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import qualified ModuleA as A (stuffA, stuffB)" - , "main = print (A.stuffA, A.stuffB)" - ]) - , testSession "extend multi line import with value" $ template - (T.unlines - [ "module ModuleA where" - , "stuffA :: Double" - , "stuffA = 0.00750" - , "stuffB :: Integer" - , "stuffB = 123" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - (Range (Position 3 17) (Position 3 18)) - "Add stuffA to the import list of ModuleA" - (T.unlines - [ "module ModuleB where" - , "import ModuleA (stuffA, stuffB" - , " )" - , "main = print (stuffA, stuffB)" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -addExtensionTests :: TestTree -addExtensionTests = testGroup "add language extension actions" - [ testSession "add NamedFieldPuns language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add NamedFieldPuns extension" - (T.unlines - [ "{-# LANGUAGE NamedFieldPuns #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - , testSession "add RecordWildCards language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add RecordWildCards extension" - (T.unlines - [ "{-# LANGUAGE RecordWildCards #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - ] - where - template initialContent range expectedAction expectedContents = do - doc <- openDoc' "Module.hs" "haskell" initialContent - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions doc range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ expectedContents @=? contentAfterAction - - -insertNewDefinitionTests :: TestTree -insertNewDefinitionTests = testGroup "insert new definition actions" - [ testSession "insert new function definition" $ do - let txtB = - ["foo True = select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines (txtB ++ - [ "" - , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" - ] - ++ txtB') - , testSession "define a hole" $ do - let txtB = - ["foo True = _select [True]" - , "" - ,"foo False = False" - ] - txtB' = - ["" - ,"someOtherCode = ()" - ] - docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB (R 1 0 1 50) - liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ contentAfterAction @?= T.unlines ( - ["foo True = select [True]" - , "" - ,"foo False = False" - , "" - , "select :: [Bool] -> Bool" - , "select = error \"not implemented\"" - ] - ++ txtB') - ] - -fixConstructorImportTests :: TestTree -fixConstructorImportTests = testGroup "fix import actions" - [ testSession "fix constructor import" $ template - (T.unlines - [ "module ModuleA where" - , "data A = Constructor" - ]) - (T.unlines - [ "module ModuleB where" - , "import ModuleA(Constructor)" - ]) - (Range (Position 1 10) (Position 1 11)) - "Fix import of A(Constructor)" - (T.unlines - [ "module ModuleB where" - , "import ModuleA(A(Constructor))" - ]) - ] - where - template contentA contentB range expectedAction expectedContentB = do - _docA <- openDoc' "ModuleA.hs" "haskell" contentA - docB <- openDoc' "ModuleB.hs" "haskell" contentB - _diags <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions docB range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents docB - liftIO $ expectedContentB @=? contentAfterAction - -importRenameActionTests :: TestTree -importRenameActionTests = testGroup "import rename actions" - [ testSession "Data.Mape -> Data.Map" $ check "Map" - , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where - check modname = do - let content = T.unlines - [ "module Testing where" - , "import Data.Mape" - ] - doc <- openDoc' "Testing.hs" "haskell" content - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) - let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] - executeCodeAction changeToMap - contentAfterAction <- documentContents doc - let expectedContentAfterAction = T.unlines - [ "module Testing where" - , "import Data." <> modname - ] - liftIO $ expectedContentAfterAction @=? contentAfterAction - -fillTypedHoleTests :: TestTree -fillTypedHoleTests = let - - sourceCode :: T.Text -> T.Text -> T.Text -> T.Text - sourceCode a b c = T.unlines - [ "module Testing where" - , "" - , "globalConvert :: Int -> String" - , "globalConvert = undefined" - , "" - , "globalInt :: Int" - , "globalInt = 3" - , "" - , "bar :: Int -> Int -> String" - , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" - , " localConvert = (flip replicate) 'x'" - - ] - - check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree - check actionTitle - oldA oldB oldC - newA newB newC = testSession (T.unpack actionTitle) $ do - let originalCode = sourceCode oldA oldB oldC - let expectedCode = sourceCode newA newB newC - doc <- openDoc' "Testing.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) - let chosenAction = pickActionWithTitle actionTitle actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "fill typed holes" - [ check "replace hole `_` with show" - "_" "n" "n" - "show" "n" "n" - - , check "replace hole `_` with globalConvert" - "_" "n" "n" - "globalConvert" "n" "n" - -#if MIN_GHC_API_VERSION(8,6,0) - , check "replace hole `_convertme` with localConvert" - "_convertme" "n" "n" - "localConvert" "n" "n" -#endif - - , check "replace hole `_b` with globalInt" - "_a" "_b" "_c" - "_a" "globalInt" "_c" - - , check "replace hole `_c` with globalInt" - "_a" "_b" "_c" - "_a" "_b" "globalInt" - -#if MIN_GHC_API_VERSION(8,6,0) - , check "replace hole `_c` with parameterInt" - "_a" "_b" "_c" - "_a" "_b" "parameterInt" -#endif - ] - -addSigActionTests :: TestTree -addSigActionTests = let - header = "{-# OPTIONS_GHC -Wmissing-signatures #-}" - moduleH = "module Sigs where" - before def = T.unlines [header, moduleH, def] - after' def sig = T.unlines [header, moduleH, sig, def] - - def >:: sig = testSession (T.unpack def) $ do - let originalCode = before def - let expectedCode = after' def sig - doc <- openDoc' "Sigs.hs" "haskell" originalCode - _ <- waitForDiagnostics - actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound)) - let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands - executeCodeAction chosenAction - modifiedCode <- documentContents doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ "abc = True" >:: "abc :: Bool" - , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" - , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" - , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" - , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" - , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" - ] - -addSigLensesTests :: TestTree -addSigLensesTests = let - missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}" - notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = "module Sigs where" - other = T.unlines ["f :: Integer -> Integer", "f x = 3"] - before withMissing def - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] - after' withMissing def sig - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] - - sigSession withMissing def sig = testSession (T.unpack def) $ do - let originalCode = before withMissing def - let expectedCode = after' withMissing def sig - doc <- openDoc' "Sigs.hs" "haskell" originalCode - [CodeLens {_command = Just c}] <- getCodeLenses doc - executeCommand c - modifiedCode <- getDocumentEdit doc - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ testGroup "with warnings enabled" - [ sigSession True "abc = True" "abc :: Bool" - , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - ] - , testGroup "with warnings disabled" - [ sigSession False "abc = True" "abc :: Bool" - , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - ] - ] - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst (get, check) pos targetRange title = testSession title $ do - doc <- openTestDataDoc sourceFilePath - found <- get doc pos - check found targetRange - - checkDefs :: [Location] -> [Expect] -> Session () - checkDefs defs expectations = traverse_ check expectations where - - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - - checkHover :: Maybe Hover -> [Expect] -> Session () - checkHover hover expectations = traverse_ check expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests ] - - test runDef runHover look expect title = - ( runDef $ tst def look expect title - , runHover $ tst hover look expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out - - -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR] - fffL8 = Position 8 4 ; - fffL14 = Position 14 7 ; - aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3] - dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16] - dcL12 = Position 12 11 ; - xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]] - tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]] - vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6] - opL16 = Position 16 15 ; op = [mkR 17 2 17 4] - opL18 = Position 18 22 ; opp = [mkR 18 13 18 17] - aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11] - b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7] - xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]] - clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]] - clL25 = Position 25 9 - eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]] - dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21] - dnbL30 = Position 30 23 - lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27] - lclL33 = Position 33 22 - mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14] - mclL37 = Position 37 1 - spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] - intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]] - tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] - innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - in - mkFindTests - -- def hover look expect - [ test yes yes fffL4 fff "field in record definition" - , test broken broken fffL8 fff "field in record construction #71" - , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- 120 - , test yes yes dcL7 tcDC "data constructor record #247" - , test yes yes dcL12 tcDC "data constructor plain" -- 121 - , test yes yes tcL6 tcData "type constructor #248" -- 147 - , test broken yes xtcL5 xtc "type constructor external #248,249" - , test broken yes xvL20 xvMsg "value external package #249" -- 120 - , test yes yes vvL16 vv "plain parameter" -- 120 - , test yes yes aL18 apmp "pattern match name" -- 120 - , test yes yes opL16 op "top-level operator" -- 120, 123 - , test yes yes opL18 opp "parameter operator" -- 120 - , test yes yes b'L19 bp "name in backticks" -- 120 - , test yes yes clL23 cls "class in instance declaration #250" - , test yes yes clL25 cls "class in signature #250" -- 147 - , test broken yes eclL15 ecls "external class in signature #249,250" - , test yes yes dnbL29 dnb "do-notation bind" -- 137 - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind" -- 137 - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #246" - , test yes yes spaceL37 space "top-level fn on space #315" - , test no broken docL41 doc "documentation #7" - , test no yes eitL40 kindE "kind of Either #273" - , test no yes intL40 kindI "kind of Int #273" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #273" - , test no yes intL41 litI "literal Int in hover info #274" - , test no yes chrL36 litC "literal Char in hover info #274" - , test no yes txtL8 litT "literal Text in hover info #274" - , test no yes lstL43 litL "literal List in hover info #274" - , test no yes docL41 constr "type constraint in hover info #283" - , test broken broken outL45 outSig "top-level signature #310" - , test broken broken innL48 innSig "inner signature #310" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - -pluginTests :: TestTree -pluginTests = testSessionWait "plugins" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}" - , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}" - , "module Testing where" - , "import Data.Proxy" - , "import GHC.TypeLits" - -- This function fails without plugins being initialized. - , "f :: forall n. KnownNat n => Proxy n -> Integer" - , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))" - , "foo :: Int -> Int -> Int" - , "foo a b = a + c" - ] - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (8, 14), "Variable not in scope: c")] - ) - ] - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence -1). Assert either - -- of them. - (run $ expectError content (2, -1)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- openDoc' "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- openDoc' "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] - ) - ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/digital-asset/ghcide/pull/212 - testSessionWait "load" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module A where", - "import \"template-haskell\" Language.Haskell.TH", - "a :: Integer", - "a = $(litE $ IntegerL 3)" - ] - sourceB = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module B where", - "import A", - "import \"template-haskell\" Language.Haskell.TH", - "b :: Integer", - "b = $(litE $ IntegerL $ a) + n" - ] - _ <- openDoc' "A.hs" "haskell" sourceA - _ <- openDoc' "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] - ] - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ testSessionWait "variable" $ do - let source = T.unlines ["module A where", "f = hea"] - docId <- openDoc' "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 7) - liftIO $ map dropDocs compls @?= - [complItem "head" (Just CiFunction) (Just "[a] -> a")] - let [CompletionItem { _documentation = headDocs}] = compls - checkDocText "head" headDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "constructor" $ do - let source = T.unlines ["module A where", "f = Tru"] - docId <- openDoc' "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 7) - liftIO $ map dropDocs compls @?= - [ complItem "True" (Just CiConstructor) (Just "Bool") -#if MIN_GHC_API_VERSION(8,6,0) - , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b") -#else - , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") -#endif - ] - , testSessionWait "type" $ do - let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"] - docId <- openDoc' "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ] - changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]] - compls <- getCompletions docId (Position 2 7) - liftIO $ map dropDocs compls @?= - [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint") - , complItem "Bool" (Just CiStruct) (Just "*") ] - let [ CompletionItem { _documentation = boundedDocs}, - CompletionItem { _documentation = boolDocs } ] = compls - checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "name the upper and lower limits" -#endif - ] - checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ] - , testSessionWait "qualified" $ do - let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"] - docId <- openDoc' "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ] - changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]] - compls <- getCompletions docId (Position 2 15) - liftIO $ map dropDocs compls @?= - [complItem "head" (Just CiFunction) (Just "[a] -> a")] - let [CompletionItem { _documentation = headDocs}] = compls - checkDocText "head" headDocs [ "Defined in 'Prelude'" -#if MIN_GHC_API_VERSION(8,6,5) - , "Extract the first element of a list" -#endif - ] - , testSessionWait "keyword" $ do - let source = T.unlines ["module A where", "f = newty"] - docId <- openDoc' "A.hs" "haskell" source - compls <- getCompletions docId (Position 1 9) - liftIO $ compls @?= [keywordItem "newtype"] - ] - where - dropDocs :: CompletionItem -> CompletionItem - dropDocs ci = ci { _documentation = Nothing } - complItem label kind ty = CompletionItem - { _label = label - , _kind = kind - , _detail = (":: " <>) <$> ty - , _documentation = Nothing - , _deprecated = Nothing - , _preselect = Nothing - , _sortText = Nothing - , _filterText = Nothing - , _insertText = Nothing - , _insertTextFormat = Just PlainText - , _textEdit = Nothing - , _additionalTextEdits = Nothing - , _commitCharacters = Nothing - , _command = Nothing - , _xdata = Nothing - } - keywordItem label = CompletionItem - { _label = label - , _kind = Just CiKeyword - , _detail = Nothing - , _documentation = Nothing - , _deprecated = Nothing - , _preselect = Nothing - , _sortText = Nothing - , _filterText = Nothing - , _insertText = Nothing - , _insertTextFormat = Nothing - , _textEdit = Nothing - , _additionalTextEdits = Nothing - , _commitCharacters = Nothing - , _command = Nothing - , _xdata = Nothing - } - getDocText (CompletionDocString s) = s - getDocText (CompletionDocMarkup (MarkupContent _ s)) = s - checkDocText thing Nothing _ - = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found" - checkDocText thing (Just doc) items - = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $ - all (`T.isInfixOf` getDocText doc) items - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a x = ()"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" - SkStruct - (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe"] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- openDoc' "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkClass - Nothing - loc - loc - (Just $ List cc) - -pattern R :: Int -> Int -> Int -> Int -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: Int -> Int -> Int -> Int -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - ----------------------------------------------------------------------- --- Utils - - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWait :: String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction -pickActionWithTitle title actions = head - [ action - | CACodeAction action@CodeAction{ _title = actionTitle } <- actions - , title == actionTitle ] - -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = withTempDir $ \dir -> do - ghcideExe <- locateGhcideExecutable - - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ dir ++ "/Data" - - let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir] - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } - runSessionWithConfig conf cmd lspTestCaps dir s - where - conf = defaultConfig - -- If you uncomment this you can see all logging - -- which can be quite useful for debugging. - -- { logStdErr = True, logColor = False } - -- If you really want to, you can also see all messages - -- { logMessages = True, logColor = False } - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - openDoc' path "haskell" source - -findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] -findCodeActions doc range expectedTitles = do - actions <- getCodeActions doc range - let matches = sequence - [ listToMaybe - [ action - | CACodeAction action@CodeAction { _title = actionTitle } <- actions - , actionTitle == expectedTitle ] - | expectedTitle <- expectedTitles] - let msg = show - [ actionTitle - | CACodeAction CodeAction { _title = actionTitle } <- actions - ] - ++ "is not a superset of " - ++ show expectedTitles - liftIO $ case matches of - Nothing -> assertFailure msg - Just _ -> pure () - return (fromJust matches) - -findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction -findCodeAction doc range t = head <$> findCodeActions doc range [t] - -unitTests :: TestTree -unitTests = do - testGroup "Unit" - [ testCase "empty file path" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "" - ] - --- | Wrapper around 'LSPTest.openDoc'' that sends file creation events -openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier -openDoc' fp name contents = do - res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents - sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated]) - return res - -positionMappingTests :: TestTree -positionMappingTests = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= Just (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= Just (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= Just (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= Just (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= Just (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= Just (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= Just (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= Just (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= Just (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= Just (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= Just (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= Just (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= Just (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= Just (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= Just (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= Just (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= Just (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= Just (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === Just oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === Just newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - row <- choose (0, max 0 $ rows - 1) - let columns = Rope.columns (nthLine row r) - column <- choose (0, max 0 $ columns - 1) - pure $ Position row column - where rows = Rope.rows r - -genRange :: Rope -> Gen Range -genRange r = do - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - startLine - endLine <- choose (startLine, startLine + maxLineDiff) - let columns = Rope.columns (nthLine endLine r) - endColumn <- - if startLine == endLine - then choose (startColumn, columns) - else choose (0, max 0 $ columns - 1) - pure $ Range startPos (Position endLine endColumn) - where rows = Rope.rows r - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> Rope -nthLine i r - | i < 0 = error $ "Negative line number: " <> show i - | i == 0 && Rope.rows r == 0 = r - | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) - | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} +#include "ghc-api-version.h" + +module Main (main) where + +import Control.Applicative.Combinators +import Control.Exception (bracket, catch) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, Value) +import Data.Foldable +import Data.List.Extra +import Data.Rope.UTF16 (Rope) +import qualified Data.Rope.UTF16 as Rope +import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent) +import Development.IDE.GHC.Util +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Spans.Common +import Development.IDE.Test +import Development.IDE.Test.Runfiles +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message) +import Language.Haskell.LSP.VFS (applyChange) +import Network.URI +import System.Environment.Blank (getEnv, setEnv, unsetEnv) +import System.FilePath +import System.IO.Extra +import System.Directory +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Ingredients.Rerun +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Data.Maybe + +main :: IO () +main = do + -- We mess with env vars so run single-threaded. + setEnv "TASTY_NUM_THREADS" "1" True + defaultMainWithRerun $ testGroup "HIE" + [ testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest) + void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification) + closeDoc doc + void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) + , initializeResponseTests + , completionTests + , cppTests + , diagnosticTests + , codeActionTests + , codeLensesTests + , outlineTests + , findDefinitionAndHoverTests + , pluginTests + , preprocessorTests + , thTests + , safeTests + , unitTests + , haddockTests + , positionMappingTests + , watchedFilesTests + , cradleTests + , dependentFileTest + ] + +initializeResponseTests :: TestTree +initializeResponseTests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO InitializeResponse -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just True) + , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just True) + , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False) + , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False) + , chk "NO find references" _referencesProvider Nothing + , chk "NO doc highlight" _documentHighlightProvider Nothing + , chk " doc symbol" _documentSymbolProvider (Just True) + , chk "NO workspace symbol" _workspaceSymbolProvider Nothing + , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True + , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing + , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO doc range formatting" + _documentRangeFormattingProvider Nothing + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider (Just $ RenameOptionsStatic False) + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False) + , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False) + , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"]) + , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )})) + , chk "NO experimental" _experimental Nothing + ] where + + tds = Just (TDSOptions (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TdSyncIncremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree + che title getActual _expected = testCase title doTest + where + doTest = do + ir <- getInitializeResponse + let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir + True @=? T.isSuffixOf "typesignature.add" command + + + innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner + innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c + innerCaps _ = error "this test only expects inner capabilities" + + acquire :: IO InitializeResponse + acquire = run initializeResponse + + release :: InitializeResponse -> IO () + release = const $ pure () + + +diagnosticTests :: TestTree +diagnosticTests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 19)) + , _rangeLength = Nothing + , _text = "where" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest) + void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification) + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 15) (Position 0 18)) + , _rangeLength = Nothing + , _text = "wher" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DsError, (2, 14), "Variable not in scope: ab") + , (DsError, (4, 10), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DsError, (2,4), aMessage)]) + , ("B.hs", [(DsError, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 0 0) (Position 0 20)) + , _rangeLength = Nothing + , _text = "" + } + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testSessionWait "add missing module (non workspace)" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB + expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA + expectDiagnostics [("/tmp/ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleB.hs" + , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] + ) + ] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217") + ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DsWarning, (2, 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + diagsNot <- skipManyTill anyMessage diagnostic + let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg = _message (head (toList diags) :: Diagnostic) + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a + , testSessionWait "haddock parse error" $ do + let fooContent = T.unlines + [ "module Foo where" + , "foo :: Int" + , "foo = 1 {-|-}" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DsError, (2, 8), "Parse error on input") + ] + ) + ] + , testSessionWait "strip file path" $ do + let + name = "Testing" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + Lsp.params . + Lsp.diagnostics . + Lens.folded . + Lsp.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + ] + +codeActionTests :: TestTree +codeActionTests = testGroup "code actions" + [ renameActionTests + , typeWildCardActionTests + , removeImportTests + , extendImportTests + , suggestImportTests + , addExtensionTests + , fixConstructorImportTests + , importRenameActionTests + , fillTypedHoleTests + , addSigActionTests + , insertNewDefinitionTests + ] + +codeLensesTests :: TestTree +codeLensesTests = testGroup "code lenses" + [ addSigLensesTests + ] + +watchedFilesTests :: TestTree +watchedFilesTests = testGroup "watched files" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + + -- Expect 4 subscriptions (A does not get any because it's VFS): + -- - /path-to-workspace/WatchedFilesMissingModule.hs + -- - /path-to-workspace/WatchedFilesMissingModule.lhs + -- - /path-to-workspace/src/WatchedFilesMissingModule.hs + -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs + liftIO $ length watchedFileRegs @?= 4 + + , testSession' "non workspace file" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification + + -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace): + -- - /path-to-workspace/WatchedFilesMissingModule.hs + -- - /path-to-workspace/WatchedFilesMissingModule.lhs + liftIO $ length watchedFileRegs @?= 2 + + -- TODO add a test for didChangeWorkspaceFolder + ] + +renameActionTests :: TestTree +renameActionTests = testGroup "rename actions" + [ testSession "change to local variable name" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argNme" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "foo :: Int -> Int" + , "foo argName = argName" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "change to name of imported function" $ do + let content = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybToList" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’" + executeCodeAction action + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data.Maybe (maybeToList)" + , "foo :: Maybe a -> [a]" + , "foo = maybeToList" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "suggest multiple local variable names" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Char -> Char -> Char -> Char" + , "foo argument1 argument2 argument3 = argumentX" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45)) + ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"] + return() + , testSession "change infix function" $ do + let content = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monnus` y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20)) + [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ] + executeCodeAction fixTypo + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "monus :: Int -> Int" + , "monus x y = max 0 (x - y)" + , "foo x y = x `monus` y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +typeWildCardActionTests :: TestTree +typeWildCardActionTests = testGroup "type wildcard actions" + [ testSession "global signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x = x" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (p -> p)" + , "func x = x" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "multi-line message" $ do + let content = T.unlines + [ "module Testing where" + , "func :: _" + , "func x y = x + y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: (Integer -> Integer -> Integer)" + , "func x y = x + y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "local signature" $ do + let content = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: _" + , " y = x * 2" + , " in y" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10)) + let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands + , "Use type signature" `T.isInfixOf` actionTitle + ] + executeCodeAction addSignature + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "func :: Int -> Int" + , "func x =" + , " let y :: (Int)" + , " y = x * 2" + , " in y" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +removeImportTests :: TestTree +removeImportTests = testGroup "remove import actions" + [ testSession "redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "qualified redundant" $ do + let contentA = T.unlines + [ "module ModuleA where" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA" + , "stuffB :: Integer" + , "stuffB = 123" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "stuffB :: Integer" + , "stuffB = 123" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant binding" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "stuffA = False" + , "stuffB :: Integer" + , "stuffB = 123" + , "stuffC = ()" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffA, stuffB, stuffC, stuffA)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant operator" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "a !! b = a" + , "a b = a" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A ((), stuffB, (!!))" + , "main = print A.stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove !!, from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print A.stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant all import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data A = A" + , "stuffB :: Integer" + , "stuffB = 123" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (A(..), stuffB)" + , "main = print stuffB" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (stuffB)" + , "main = print stuffB" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + , testSession "redundant constructor import" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "data D = A | B" + , "data E = F" + ] + _docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(A,B), E(F))" + , "main = B" + ] + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + [CACodeAction action@CodeAction { _title = actionTitle }] + <- getCodeActions docB (Range (Position 2 0) (Position 2 5)) + liftIO $ "Remove A, E, F from import" @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + let expectedContentAfterAction = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA (D(B))" + , "main = B" + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + ] + +extendImportTests :: TestTree +extendImportTests = testGroup "extend import actions" + [ testSession "extend single line import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + "Add stuffA to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffA, stuffB)" + , "main = print (stuffA, stuffB)" + ]) + , testSession "extend single line import with operator" $ template + (T.unlines + [ "module ModuleA where" + , "(.*) :: Integer -> Integer -> Integer" + , "x .* y = x * y" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A (stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + "Add .* to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA as A ((.*), stuffB)" + , "main = print (stuffB .* stuffB)" + ]) + , testSession "extend single line import with type" $ template + (T.unlines + [ "module ModuleA where" + , "type A = Double" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + , "b :: A" + , "b = 0" + ]) + (Range (Position 2 5) (Position 2 5)) + "Add A to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = 0" + ]) + , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A)" + , "b :: A" + , "b = Constructor" + ]) + (Range (Position 2 5) (Position 2 5)) + "Add Constructor to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA (A(Constructor))" + , "b :: A" + , "b = Constructor" + ]) + , testSession "extend single line qualified import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + "Add stuffA to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import qualified ModuleA as A (stuffA, stuffB)" + , "main = print (A.stuffA, A.stuffB)" + ]) + , testSession "extend multi line import with value" $ template + (T.unlines + [ "module ModuleA where" + , "stuffA :: Double" + , "stuffA = 0.00750" + , "stuffB :: Integer" + , "stuffB = 123" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + (Range (Position 3 17) (Position 3 18)) + "Add stuffA to the import list of ModuleA" + (T.unlines + [ "module ModuleB where" + , "import ModuleA (stuffA, stuffB" + , " )" + , "main = print (stuffA, stuffB)" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +suggestImportTests :: TestTree +suggestImportTests = testGroup "suggest import actions" + [ testGroup "Dont want suggestion" + [ -- extend import + test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + -- data constructor + , test False [] "f = First" [] "import Data.Monoid (First)" + -- internal module + , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" + -- package not in scope + , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + ] + , testGroup "want suggestion" + [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))" + , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)" + , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)" + , test True [] "f = First" [] "import Data.Monoid (First(First))" + , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))" + , test True [] "f = Version" [] "import Data.Version (Version(Version))" + , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))" + , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))" + , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)" + , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" + , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = (&)" [] "import Data.Function ((&))" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" + , test True [] "f = pack" [] "import Data.Text (pack)" + , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" + , test True [] "f = [] & id" [] "import Data.Function ((&))" + , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + ] + ] + where + test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do + let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other + after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other + cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}" + liftIO $ writeFileUTF8 (dir "hie.yaml") cradle + doc <- createDoc "Test.hs" "haskell" before + _diags <- waitForDiagnostics + let defLine = length imps + 1 + range = Range (Position defLine 0) (Position defLine maxBound) + actions <- getCodeActions doc range + if wanted + then do + action <- liftIO $ pickActionWithTitle newImp actions + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ after @=? contentAfterAction + else + liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] + + +addExtensionTests :: TestTree +addExtensionTests = testGroup "add language extension actions" + [ testSession "add NamedFieldPuns language extension" $ template + (T.unlines + [ "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { getA } = getA" + ]) + (Range (Position 0 0) (Position 0 0)) + "Add NamedFieldPuns extension" + (T.unlines + [ "{-# LANGUAGE NamedFieldPuns #-}" + , "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { getA } = getA" + ]) + , testSession "add RecordWildCards language extension" $ template + (T.unlines + [ "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { .. } = getA" + ]) + (Range (Position 0 0) (Position 0 0)) + "Add RecordWildCards extension" + (T.unlines + [ "{-# LANGUAGE RecordWildCards #-}" + , "module Module where" + , "" + , "data A = A { getA :: Bool }" + , "" + , "f :: A -> Bool" + , "f A { .. } = getA" + ]) + ] + where + template initialContent range expectedAction expectedContents = do + doc <- createDoc "Module.hs" "haskell" initialContent + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions doc range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ expectedContents @=? contentAfterAction + + +insertNewDefinitionTests :: TestTree +insertNewDefinitionTests = testGroup "insert new definition actions" + [ testSession "insert new function definition" $ do + let txtB = + ["foo True = select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines (txtB ++ + [ "" + , "select :: [Bool] -> Bool" + , "select = error \"not implemented\"" + ] + ++ txtB') + , testSession "define a hole" $ do + let txtB = + ["foo True = _select [True]" + , "" + ,"foo False = False" + ] + txtB' = + ["" + ,"someOtherCode = ()" + ] + docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB') + _ <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB (R 1 0 1 50) + liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool" + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ contentAfterAction @?= T.unlines ( + ["foo True = select [True]" + , "" + ,"foo False = False" + , "" + , "select :: [Bool] -> Bool" + , "select = error \"not implemented\"" + ] + ++ txtB') + ] + +fixConstructorImportTests :: TestTree +fixConstructorImportTests = testGroup "fix import actions" + [ testSession "fix constructor import" $ template + (T.unlines + [ "module ModuleA where" + , "data A = Constructor" + ]) + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Constructor)" + ]) + (Range (Position 1 10) (Position 1 11)) + "Fix import of A(Constructor)" + (T.unlines + [ "module ModuleB where" + , "import ModuleA(A(Constructor))" + ]) + ] + where + template contentA contentB range expectedAction expectedContentB = do + _docA <- createDoc "ModuleA.hs" "haskell" contentA + docB <- createDoc "ModuleB.hs" "haskell" contentB + _diags <- waitForDiagnostics + CACodeAction action@CodeAction { _title = actionTitle } : _ + <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> + getCodeActions docB range + liftIO $ expectedAction @=? actionTitle + executeCodeAction action + contentAfterAction <- documentContents docB + liftIO $ expectedContentB @=? contentAfterAction + +importRenameActionTests :: TestTree +importRenameActionTests = testGroup "import rename actions" + [ testSession "Data.Mape -> Data.Map" $ check "Map" + , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where + check modname = do + let content = T.unlines + [ "module Testing where" + , "import Data.Mape" + ] + doc <- createDoc "Testing.hs" "haskell" content + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16)) + let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ] + executeCodeAction changeToMap + contentAfterAction <- documentContents doc + let expectedContentAfterAction = T.unlines + [ "module Testing where" + , "import Data." <> modname + ] + liftIO $ expectedContentAfterAction @=? contentAfterAction + +fillTypedHoleTests :: TestTree +fillTypedHoleTests = let + + sourceCode :: T.Text -> T.Text -> T.Text -> T.Text + sourceCode a b c = T.unlines + [ "module Testing where" + , "" + , "globalConvert :: Int -> String" + , "globalConvert = undefined" + , "" + , "globalInt :: Int" + , "globalInt = 3" + , "" + , "bar :: Int -> Int -> String" + , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where" + , " localConvert = (flip replicate) 'x'" + + ] + + check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree + check actionTitle + oldA oldB oldC + newA newB newC = testSession (T.unpack actionTitle) $ do + let originalCode = sourceCode oldA oldB oldC + let expectedCode = sourceCode newA newB newC + doc <- createDoc "Testing.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "fill typed holes" + [ check "replace hole `_` with show" + "_" "n" "n" + "show" "n" "n" + + , check "replace hole `_` with globalConvert" + "_" "n" "n" + "globalConvert" "n" "n" + +#if MIN_GHC_API_VERSION(8,6,0) + , check "replace hole `_convertme` with localConvert" + "_convertme" "n" "n" + "localConvert" "n" "n" +#endif + + , check "replace hole `_b` with globalInt" + "_a" "_b" "_c" + "_a" "globalInt" "_c" + + , check "replace hole `_c` with globalInt" + "_a" "_b" "_c" + "_a" "_b" "globalInt" + +#if MIN_GHC_API_VERSION(8,6,0) + , check "replace hole `_c` with parameterInt" + "_a" "_b" "_c" + "_a" "_b" "parameterInt" +#endif + ] + +addSigActionTests :: TestTree +addSigActionTests = let + header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" + before def = T.unlines [header, moduleH, def] + after' def sig = T.unlines [header, moduleH, sig, def] + + def >:: sig = testSession (T.unpack def) $ do + let originalCode = before def + let expectedCode = after' def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + _ <- waitForDiagnostics + actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound)) + chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands + executeCodeAction chosenAction + modifiedCode <- documentContents doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ "abc = True" >:: "abc :: Bool" + , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a" + , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String" + , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool" + , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a" + , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2" + , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a" + ] + +addSigLensesTests :: TestTree +addSigLensesTests = let + missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" + notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" + moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where" + other = T.unlines ["f :: Integer -> Integer", "f x = 3"] + before withMissing def + = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] + after' withMissing def sig + = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] + + sigSession withMissing def sig = testSession (T.unpack def) $ do + let originalCode = before withMissing def + let expectedCode = after' withMissing def sig + doc <- createDoc "Sigs.hs" "haskell" originalCode + [CodeLens {_command = Just c}] <- getCodeLenses doc + executeCommand c + modifiedCode <- getDocumentEdit doc + liftIO $ expectedCode @=? modifiedCode + in + testGroup "add signature" + [ testGroup title + [ sigSession enableWarnings "abc = True" "abc :: Bool" + , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" + , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" + , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" + , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" + , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" + , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" + ] + | (title, enableWarnings) <- + [("with warnings enabled", True) + ,("with warnings disabled", False) + ] + ] + +checkDefs :: [Location] -> Session [Expect] -> Session () +checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where + + check (ExpectRange expectedRange) = do + assertNDefinitionsFound 1 defs + assertRangeCorrect (head defs) expectedRange + check (ExpectLocation expectedLocation) = do + assertNDefinitionsFound 1 defs + liftIO $ head defs @?= expectedLocation + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertNDefinitionsFound :: Int -> [a] -> Session () + assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + + +findDefinitionAndHoverTests :: TestTree +findDefinitionAndHoverTests = let + + tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + doc <- openTestDataDoc (dir sourceFilePath) + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (HoverContents MarkupContent{_value = msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ (adjust $ _start expectedRange) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath ] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look expect title + , runHover $ tst hover look expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out + + -- search locations expectations on results + fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14] + in + mkFindTests + -- def hover look expect + [ test yes yes fffL4 fff "field in record definition" + , test broken broken fffL8 fff "field in record construction #71" + , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- 120 + , test yes yes dcL7 tcDC "data constructor record #247" + , test yes yes dcL12 tcDC "data constructor plain" -- 121 + , test yes yes tcL6 tcData "type constructor #248" -- 147 + , test broken yes xtcL5 xtc "type constructor external #248,249" + , test broken yes xvL20 xvMsg "value external package #249" -- 120 + , test yes yes vvL16 vv "plain parameter" -- 120 + , test yes yes aL18 apmp "pattern match name" -- 120 + , test yes yes opL16 op "top-level operator" -- 120, 123 + , test yes yes opL18 opp "parameter operator" -- 120 + , test yes yes b'L19 bp "name in backticks" -- 120 + , test yes yes clL23 cls "class in instance declaration #250" + , test yes yes clL25 cls "class in signature #250" -- 147 + , test broken yes eclL15 ecls "external class in signature #249,250" + , test yes yes dnbL29 dnb "do-notation bind" -- 137 + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind" -- 137 + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #246" + , test yes yes spaceL37 space "top-level fn on space #315" + , test no broken docL41 doc "documentation #7" + , test no yes eitL40 kindE "kind of Either #273" + , test no yes intL40 kindI "kind of Int #273" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #273" + , test no yes intL41 litI "literal Int in hover info #274" + , test no yes chrL36 litC "literal Char in hover info #274" + , test no yes txtL8 litT "literal Text in hover info #274" + , test no yes lstL43 litL "literal List in hover info #274" + , test no yes docL41 constr "type constraint in hover info #283" + , test broken broken outL45 outSig "top-level signature #310" + , test broken broken innL48 innSig "inner signature #310" + , testM yes yes imported importedSig "Imported symbol" + , testM yes yes reexported reexportedSig "Imported symbol (reexported)" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + +checkFileCompiles :: FilePath -> TestTree +checkFileCompiles fp = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + expectNoMoreDiagnostics 0.5 + + + +pluginTests :: TestTree +pluginTests = (`xfail8101` "known broken (#556)") + $ testSessionWait "plugins" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}" + , "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}" + , "module Testing where" + , "import Data.Proxy" + , "import GHC.TypeLits" + -- This function fails without plugins being initialized. + , "f :: forall n. KnownNat n => Proxy n -> Integer" + , "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))" + , "foo :: Int -> Int -> Int" + , "foo a b = a + c" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (8, 14), "Variable not in scope: c")] + ) + ] + +cppTests :: TestTree +cppTests = + testGroup "cpp" + [ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence -1). Assert either + -- of them. + (run $ expectError content (2, -1)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 + +preprocessorTests :: TestTree +preprocessorTests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (2, 8), "Variable not in scope: z")] + ) + ] + + +safeTests :: TestTree +safeTests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/digital-asset/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] + +thTests :: TestTree +thTests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/digital-asset/ghcide/pull/212 + testSessionWait "load" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module A where", + "import \"template-haskell\" Language.Haskell.TH", + "a :: Integer", + "a = $(litE $ IntegerL 3)" + ] + sourceB = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module B where", + "import A", + "import \"template-haskell\" Language.Haskell.TH", + "b :: Integer", + "b = $(litE $ IntegerL $ a) + n" + ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] + , testSessionWait "newtype-closure" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE DeriveDataTypeable #-}" + ,"{-# LANGUAGE TemplateHaskell #-}" + ,"module A (a) where" + ,"import Data.Data" + ,"import Language.Haskell.TH" + ,"newtype A = A () deriving (Data)" + ,"a :: ExpQ" + ,"a = [| 0 |]"] + let sourceB = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + ,"module B where" + ,"import A" + ,"b :: Int" + ,"b = $( a )" ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + return () + ] + +completionTests :: TestTree +completionTests + = testGroup "completion" + [ testSessionWait "variable" $ do + let source = T.unlines ["module A where", "f = hea"] + docId <- createDoc "A.hs" "haskell" source + compls <- getCompletions docId (Position 1 7) + liftIO $ map dropDocs compls @?= + [complItem "head" (Just CiFunction) (Just "[a] -> a")] + let [CompletionItem { _documentation = headDocs}] = compls + checkDocText "head" headDocs [ "Defined in 'Prelude'" +#if MIN_GHC_API_VERSION(8,6,5) + , "Extract the first element of a list" +#endif + ] + , testSessionWait "constructor" $ do + let source = T.unlines ["module A where", "f = Tru"] + docId <- createDoc "A.hs" "haskell" source + compls <- getCompletions docId (Position 1 7) + liftIO $ map dropDocs compls @?= + [ complItem "True" (Just CiConstructor) (Just "Bool") +#if MIN_GHC_API_VERSION(8,6,0) + , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b") +#else + , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b") +#endif + ] + , testSessionWait "type" $ do + let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"] + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ] + changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]] + compls <- getCompletions docId (Position 2 7) + liftIO $ map dropDocs compls @?= + [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint") + , complItem "Bool" (Just CiStruct) (Just "*") ] + let [ CompletionItem { _documentation = boundedDocs}, + CompletionItem { _documentation = boolDocs } ] = compls + checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'" +#if MIN_GHC_API_VERSION(8,6,5) + , "name the upper and lower limits" +#endif + ] + checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ] + , testSessionWait "qualified" $ do + let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"] + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ] + changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]] + compls <- getCompletions docId (Position 2 15) + liftIO $ map dropDocs compls @?= + [complItem "head" (Just CiFunction) (Just "[a] -> a")] + let [CompletionItem { _documentation = headDocs}] = compls + checkDocText "head" headDocs [ "Defined in 'Prelude'" +#if MIN_GHC_API_VERSION(8,6,5) + , "Extract the first element of a list" +#endif + ] + , testSessionWait "keyword" $ do + let source = T.unlines ["module A where", "f = newty"] + docId <- createDoc "A.hs" "haskell" source + compls <- getCompletions docId (Position 1 9) + liftIO $ compls @?= [keywordItem "newtype"] + , testSessionWait "type context" $ do + let source = T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "f = f" + ] + docId <- createDoc "A.hs" "haskell" source + expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])] + changeDoc docId + [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}" + , "module A () where" + , "f = f" + , "g :: Intege" + ] + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + compls <- getCompletions docId (Position 3 11) + liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")] + ] + where + dropDocs :: CompletionItem -> CompletionItem + dropDocs ci = ci { _documentation = Nothing } + complItem label kind ty = CompletionItem + { _label = label + , _kind = kind + , _tags = List [] + , _detail = (":: " <>) <$> ty + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Nothing + , _insertTextFormat = Just PlainText + , _textEdit = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _xdata = Nothing + } + keywordItem label = CompletionItem + { _label = label + , _kind = Just CiKeyword + , _tags = List [] + , _detail = Nothing + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Nothing + , _insertTextFormat = Nothing + , _textEdit = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _xdata = Nothing + } + getDocText (CompletionDocString s) = s + getDocText (CompletionDocMarkup (MarkupContent _ s)) = s + checkDocText thing Nothing _ + = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found" + checkDocText thing (Just doc) items + = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $ + all (`T.isInfixOf` getDocText doc) items + +outlineTests :: TestTree +outlineTests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SkInterface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15) + , docSymbol "A ()" SkInterface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11) + , docSymbol "A ()" SkInterface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a" SkFunction (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "Just foo" SkFunction (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [ docSymbolWithChildren "A" + SkStruct + (R 0 0 0 10) + [docSymbol "C" SkConstructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @=? Left + [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SkField (R 1 2 1 3) + , docSymbol "y" SkField (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 0 0 0 17) + [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left + [docSymbolWithChildren "imports" + SkModule + (R 1 0 3 24) + [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17) + , docSymbol "import Control.Exception" SkModule (R 3 0 3 24) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SkFile + Nothing + (R 0 0 maxBound 0) + loc + (Just $ List cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SkClass + Nothing + loc + loc + (Just $ List cc) + +pattern R :: Int -> Int -> Int -> Int -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +xfail8101 :: TestTree -> String -> TestTree +#if MIN_GHC_API_VERSION(8,10,0) +xfail8101 = flip expectFailBecause +#else +xfail8101 t _ = t +#endif + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +mkR :: Int -> Int -> Int -> Int -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> Int -> Int -> Int -> Int -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + +haddockTests :: TestTree +haddockTests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt + +cradleTests :: TestTree +cradleTests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "loading" [loadCradleOnlyonce] + ,testGroup "multi" [simpleMultiTest, simpleMultiTest2] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification)) + liftIO $ length msgs @?= 0 + + +dependentFileTest :: TestTree +dependentFileTest = testGroup "addDependentFile" + [testGroup "file-changed" [testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + liftIO $ writeFile (dir "dep-file.txt") "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo"] + _ <-createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics + [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] + -- Now modify the dependent file + liftIO $ writeFile (dir "dep-file.txt") "B" + let change = TextDocumentContentChangeEvent + { _range = Just (Range (Position 2 0) (Position 2 6)) + , _rangeLength = Nothing + , _text = "f = ()" + } + -- Modifying Baz will now trigger Foo to be rebuilt as well + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: T.Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +-- Stack sets this which trips up cabal in the multi-component tests. +-- However, our plugin tests rely on those env vars so we unset it locally. +withoutStackEnv :: IO a -> IO a +withoutStackEnv s = + bracket + (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState) + (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState)) + (const s) + where vars = + [ "GHC_PACKAGE_PATH" + , "GHC_ENVIRONMENT" + , "HASKELL_DIST_DIR" + , "HASKELL_PACKAGE_SANDBOX" + , "HASKELL_PACKAGE_SANDBOXES" + ] + restore var Nothing = unsetEnv var + restore var (Just val) = setEnv var val True + +simpleMultiTest :: TestTree +simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + aSource <- liftIO $ readFileUtf8 aPath + (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource + expectNoMoreDiagnostics 0.5 + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + expectNoMoreDiagnostics 0.5 + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL adoc 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: TestTree +simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + expectNoMoreDiagnostics 5 + aSource <- liftIO $ readFileUtf8 aPath + (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource + -- Need to have some delay here or the test fails + expectNoMoreDiagnostics 5 + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL adoc 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + -- Send change event. + let change = + TextDocumentContentChangeEvent + { _range = Just (Range (Position 4 0) (Position 4 0)), + _rangeLength = Nothing, + _text = "\n" + } + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] + + +---------------------------------------------------------------------- +-- Utils + + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +testSessionWait :: String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction +pickActionWithTitle title actions = do + assertBool ("Found no matching actions: " <> show titles) (not $ null matches) + return $ head matches + where + titles = + [ actionTitle + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + matches = + [ action + | CACodeAction action@CodeAction { _title = actionTitle } <- actions + , title == actionTitle + ] + +mkRange :: Int -> Int -> Int -> Int -> Range +mkRange a b c d = Range (Position a b) (Position c d) + +run :: Session a -> IO a +run s = withTempDir $ \dir -> runInDir dir s + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("test/data" prefix f) (dir f) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir s = do + ghcideExe <- locateGhcideExecutable + + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ dir ++ "/Data" + + + let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir] + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + runSessionWithConfig conf cmd lspTestCaps dir s + where + conf = defaultConfig + -- If you uncomment this you can see all logging + -- which can be quite useful for debugging. + -- { logStdErr = True, logColor = False } + -- If you really want to, you can also see all messages + -- { logMessages = True, logColor = False } + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "test/data" path + createDoc path "haskell" source + +findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction] +findCodeActions doc range expectedTitles = do + actions <- getCodeActions doc range + let matches = sequence + [ listToMaybe + [ action + | CACodeAction action@CodeAction { _title = actionTitle } <- actions + , actionTitle == expectedTitle ] + | expectedTitle <- expectedTitles] + let msg = show + [ actionTitle + | CACodeAction CodeAction { _title = actionTitle } <- actions + ] + ++ " is not a superset of " + ++ show expectedTitles + liftIO $ case matches of + Nothing -> assertFailure msg + Just _ -> pure () + return (fromJust matches) + +findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction +findCodeAction doc range t = head <$> findCodeActions doc range [t] + +unitTests :: TestTree +unitTests = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + ] + +positionMappingTests :: TestTree +positionMappingTests = + testGroup "position mapping" + [ testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= Just (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= Just (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= Just (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= Just (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= Just (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= Just (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= Just (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= Just (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= Just (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= Just (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= Just (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= Just (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= Just (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= Just (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= Just (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= Just (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= Just (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= Just (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === Just oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === Just newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + row <- choose (0, max 0 $ rows - 1) + let columns = Rope.columns (nthLine row r) + column <- choose (0, max 0 $ columns - 1) + pure $ Position row column + where rows = Rope.rows r + +genRange :: Rope -> Gen Range +genRange r = do + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - startLine + endLine <- choose (startLine, startLine + maxLineDiff) + let columns = Rope.columns (nthLine endLine r) + endColumn <- + if startLine == endLine + then choose (startColumn, columns) + else choose (0, max 0 $ columns - 1) + pure $ Range startPos (Position endLine endColumn) + where rows = Rope.rows r + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> Rope +nthLine i r + | i < 0 = error $ "Negative line number: " <> show i + | i == 0 && Rope.rows r == 0 = r + | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r) + | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r + +getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value] +getWatchedFilesSubscriptionsUntil = do + msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end) + return + [ args + | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs + , Registration _id WorkspaceDidChangeWatchedFiles args <- regs + ] diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -1,10 +1,13 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DuplicateRecordFields #-} + module Development.IDE.Test ( Cursor , cursorPosition , requireDiagnostic + , diagnostic , expectDiagnostics , expectNoMoreDiagnostics ) where @@ -15,7 +18,7 @@ import Control.Monad.IO.Class import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Language.Haskell.LSP.Test hiding (message, openDoc') +import Language.Haskell.LSP.Test hiding (message) import qualified Language.Haskell.LSP.Test as LspTest import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens as Lsp @@ -77,7 +80,7 @@ go m | Map.null m = pure () | otherwise = do - diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification + diagsNot <- skipManyTill anyMessage diagnostic let fileUri = diagsNot ^. params . uri case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of Nothing -> do @@ -95,6 +98,9 @@ ", expected " <> show expected <> " but got " <> show actual go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m + +diagnostic :: Session PublishDiagnosticsNotification +diagnostic = LspTest.message standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let