haskell/haskell-ide-engine
1
1
Fork 0
mirror of https://github.com/haskell/haskell-ide-engine.git synced 2024-08-15 22:10:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #1126 from mpickering/hie-bios

Browse Source 
Implement the HIE Bios
This commit is contained in:
fendor 2019-12-20 21:38:35 +01:00 committed by GitHub
commit 8582a960dc
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
105 changed files with 3640 additions and 2453 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.azure/linux-stack.yml
View File

@ -64,7 +64,6 @@ jobs:
source .azure/linux.bashrc
stack build --stack-yaml $(YAML_FILE) --test --bench --only-dependencies
stack install --stack-yaml $(YAML_FILE) # `hie` binary required for tests
stack --stack-yaml $(YAML_FILE) exec hoogle generate
displayName: Build Test-dependencies
- bash: |
sudo apt update

1
.azure/macos-stack.yml
View File

@ -60,7 +60,6 @@ jobs:
source .azure/macos.bashrc
stack build --stack-yaml $(YAML_FILE) --test --bench --only-dependencies
stack install --stack-yaml $(YAML_FILE) # `hie` binary required for tests
stack --stack-yaml $(YAML_FILE) exec hoogle generate
displayName: Build Test-dependencies
- bash: |
ruby -e "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/master/install)"

1
.azure/windows-stack.yml
View File

@ -62,7 +62,6 @@ jobs:
source .azure/windows.bashrc
stack build --stack-yaml $(YAML_FILE) --test --bench --only-dependencies
stack install --stack-yaml $(YAML_FILE) # `hie` binary required for tests
stack exec --stack-yaml $(YAML_FILE) hoogle generate
displayName: Build Test-dependencies
- bash: |
# TODO: try to install automatically (`choco install z3` fails and pacman is not installed)

6
.circleci/config.yml
View File

@ -26,9 +26,9 @@ defaults: &defaults
- stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }}
- stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }}
# - run:
# name: Stack upgrade
# command: stack upgrade
- run:
name: Stack upgrade
command: stack upgrade
- run:
name: Stack setup

3
.gitignore vendored
View File

@ -74,3 +74,6 @@ _build/
# stack 2.1 stack.yaml lock files
stack*.yaml.lock
shake.yaml.lock
# ignore hie.yaml's for testdata
test/**/*.yaml

14
.gitmodules vendored
View File

@ -10,20 +10,12 @@
# rm -rf path_to_submodule
[submodule "submodules/HaRe"]
path = submodules/HaRe
# url = https://github.com/bubba/HaRe.git
url = https://github.com/alanz/HaRe.git
[submodule "submodules/cabal-helper"]
path = submodules/cabal-helper
# url = https://github.com/arbor/cabal-helper.git
url = https://github.com/alanz/cabal-helper.git
# url = https://github.com/DanielG/cabal-helper.git
# Change this back once https://github.com/DanielG/cabal-helper/pull/85/ merged
url = https://github.com/bubba/cabal-helper.git
[submodule "submodules/ghc-mod"]
path = submodules/ghc-mod
# url = https://github.com/arbor/ghc-mod.git
# url = https://github.com/bubba/ghc-mod.git
url = https://github.com/alanz/ghc-mod.git
url = https://github.com/fendor/ghc-mod.git

219
README.md
View File

@ -30,16 +30,19 @@ we talk to clients.__
- [Windows-specific pre-requirements](#windows-specific-pre-requirements)
- [Download the source code](#download-the-source-code)
- [Building](#building)
- [Install via cabal](#install-via-cabal)
- [Install cabal using stack](#install-cabal-using-stack)
- [Install specific GHC Version](#install-specific-ghc-version)
- [Multiple versions of HIE (optional)](#multiple-versions-of-hie-optional)
- [Configuration](#configuration)
- [Project Configuration](#project-configuration)
- [Editor Integration](#editor-integration)
- [Using HIE with VS Code](#using-hie-with-vs-code)
- [Using VS Code with Nix](#using-vs-code-with-nix)
- [Using HIE with Sublime Text](#using-hie-with-sublime-text)
- [Using HIE with Vim or Neovim](#using-hie-with-vim-or-neovim)
- [Coc](#Coc)
- [LanguageClient-neovim](#LanguageClient-neovim)
- [Coc](#coc)
- [LanguageClient-neovim](#languageclient-neovim)
- [vim-plug](#vim-plug)
- [Clone the LanguageClient-neovim repo](#clone-the-languageclient-neovim-repo)
- [Sample `~/.vimrc`](#sample-vimrc)
@ -66,6 +69,8 @@ we talk to clients.__
- [Otherwise](#otherwise)
- [Nix: cabal-helper, No such file or directory](#nix-cabal-helper-no-such-file-or-directory)
- [Liquid Haskell](#liquid-haskell)
- [Profiling `haskell-ide-engine`.](#profiling-haskell-ide-engine)
- [Using `ghc-events-analyze`](#using-ghc-events-analyze)
## Features
@ -104,7 +109,7 @@ we talk to clients.__
![Formatting](https://i.imgur.com/cqZZ8HC.gif)
- Renaming via HaRe
- Renaming via HaRe (NOTE: HaRe is temporarily disabled)
![Renaming](https://i.imgur.com/z03G2a5.gif)
@ -228,17 +233,16 @@ stack ./install.hs stack-install-cabal
##### Install specific GHC Version
Install **Nightly** (and hoogle docs):
Install hie for the latest available and supported GHC version (and hoogle docs):
```bash
stack ./install.hs hie-8.6.4
stack ./install.hs build-data
stack ./install.hs build
```
Install **LTS** (and hoogle docs):
Install hie for a specific GHC version (and hoogle docs):
```bash
stack ./install.hs hie-8.4.4
stack ./install.hs hie-8.6.5
stack ./install.hs build-data
```
@ -303,6 +307,154 @@ There are some settings that can be configured via a `settings.json` file:
- VS Code: These settings will show up in the settings window
- LanguageClient-neovim: Create this file in `$projectdir/.vim/settings.json` or set `g:LanguageClient_settingsPath`
## Project Configuration
**For a full explanation of possible configurations, refer to [hie-bios/README](https://github.com/mpickering/hie-bios/blob/master/README.md).**
HIE will attempt to automatically detect your project configuration and set up
the environment for GHC.
| `cabal.project` | `stack.yaml` | `*.cabal` | Project selected |
|-----------------|--------------|-----------|------------------|
| ✅ | - | - | Cabal v2 |
| ❌ | ✅ | - | Stack |
| ❌ | ❌ | ✅ | Cabal (v2 or v1) |
| ❌ | ❌ | ❌ | None |
However, you can also place a `hie.yaml` file in the root of the workspace to
**explicitly** describe how to setup the environment. For example, to state that
you want to use `stack` then the configuration file would look like:
```yaml
cradle:
stack:
component: "haskell-ide-engine:lib"
```
If you use `cabal` then you probably need to specify which component you want
to use.
```yaml
cradle:
cabal:
component: "lib:haskell-ide-engine"
```
If you have a project with multiple components, you can use a cabal-multi
cradle:
```yaml
cradle:
cabal:
- path: "./test/dispatcher/"
component: "test:dispatcher-test"
- path: "./test/functional/"
component: "test:func-test"
- path: "./test/unit/"
component: "test:unit-test"
- path: "./hie-plugin-api/"
component: "lib:hie-plugin-api"
- path: "./app/MainHie.hs"
component: "exe:hie"
- path: "./app/HieWrapper.hs"
component: "exe:hie-wrapper"
- path: "./"
component: "lib:haskell-ide-engine"
```
Equivalently, you can use stack:
```yaml
cradle:
stack:
- path: "./test/dispatcher/"
component: "haskell-ide-engine:test:dispatcher-test"
- path: "./test/functional/"
component: "haskell-ide-engine:test:func-test"
- path: "./test/unit/"
component: "haskell-ide-engine:test:unit-test"
- path: "./hie-plugin-api/"
component: "hie-plugin-api:lib"
- path: "./app/MainHie.hs"
component: "haskell-ide-engine:exe:hie"
- path: "./app/HieWrapper.hs"
component: "haskell-ide-engine:exe:hie-wrapper"
- path: "./"
component: "haskell-ide-engine:lib"
```
Or you can explicitly state the program which should be used to collect
the options by supplying the path to the program. It is interpreted
relative to the current working directory if it is not an absolute path.
```yaml
cradle:
bios:
program: ".hie-bios"
```
The complete configuration is a subset of
```yaml
cradle:
cabal:
component: "optional component name"
stack:
component: "optional component name"
bios:
program: "program to run"
dependency-program: "optional program to run"
direct:
arguments: ["list","of","ghc","arguments"]
default:
none:
dependencies:
- someDep
```
There is also support for multiple cradles in a single `hie.yaml`. An example configuration for Haskell IDE Engine:
```yaml
cradle:
multi:
- path: ./test/dispatcher/
config:
cradle:
cabal:
component: "test:dispatcher-test"
- path: ./test/functional/
config:
cradle:
cabal:
component: "test:func-test"
- path: ./test/unit/
config:
cradle:
cabal:
component: "test:unit-test"
- path: ./hie-plugin-api/
config:
cradle:
cabal:
component: "lib:hie-plugin-api"
- path: ./app/MainHie.hs
config:
cradle:
cabal:
component: "exe:hie"
- path: ./app/HieWrapper.hs
config:
cradle:
cabal:
component: "exe:hie-wrapper"
- path: ./
config:
cradle:
cabal:
component: "lib:haskell-ide-engine"
```
## Editor Integration
Note to editor integrators: there is now a `hie-wrapper` executable, which is installed alongside the `hie` executable. When this is invoked in the project root directory, it attempts to work out the GHC version used in the project, and then launch the matching `hie` executable.
@ -545,10 +697,10 @@ Or you can set the environment variable `HIE_HOOGLE_DATABASE` to specify a speci
### Planned Features
- [x] Multiproject support
- [x] New-build support
- [ ] Project wide references
- [ ] Cross project find definition
- [ ] New-build support
- [ ] HaRe refactorings
- [ ] More HaRe refactorings
- [ ] More code actions
- [ ] Cross project/dependency Find Definition
- [ ] Case splitting, type insertion etc.
@ -644,18 +796,43 @@ Delete any `.ghc.environment*` files in your project root and try again. (At the
#### Otherwise
Try running `cabal update`.
### Nix: cabal-helper, No such file or directory
An error on stderr like
```
cabal-helper-wrapper: /home/<...>/.cache/cabal-helper/cabal-helper<...>: createProcess: runInteractiveProcess:
exec: does not exist (No such file or directory)
```
can happen because cabal-helper compiles and runs above executable at runtime without using nix-build, which means a Nix garbage collection can delete the paths it depends on. Delete ~/.cache/cabal-helper and restart HIE to fix this.
### Liquid Haskell
Liquid Haskell requires an SMT solver on the path. We do not take care of installing one, thus, Liquid Haskell will not run until one is installed.
The recommended SMT solver is [z3](https://github.com/Z3Prover/z3). To run the tests, it is also required to have an SMT solver on the path, otherwise the tests will fail for Liquid Haskell.
### Profiling `haskell-ide-engine`.
If you think `haskell-ide-engine` is using a lot of memory then the most useful
thing you can do is prepare a profile of the memory usage whilst you're using
the program.
1. Add `profiling: True` to the cabal.project file of `haskell-ide-engine`
2. `cabal new-build hie`
3. (IMPORTANT) Add `profiling: True` to the `cabal.project` file of the project you want to profile.
4. Make a wrapper script which calls the `hie` you built in step 2 with the additional options `+RTS -hd -l-au`
5. Modify your editor settings to call this wrapper script instead of looking for `hie` on the path
6. Try using `h-i-e` as normal and then process the `*.eventlog` which will be created using [`eventlog2html`](http://hackage.haskell.org/package/eventlog2html).
7. Repeat the process again using different profiling options if you like.
#### Using `ghc-events-analyze`
`haskell-ide-engine` contains the necessary tracing functions to work with [`ghc-events-analyze`](http://www.well-typed.com/blog/2014/02/ghc-events-analyze/). Each
request which is made will emit an event to the eventlog when it starts and finishes. This way you
can see if there are any requests which are taking a long time to complete or are blocking.
1. Make sure that `hie` is linked with the `-eventlog` option. This can be achieved by adding the flag
to the `ghc-options` field in the cabal file.
2. Run `hie` as normal but with the addition of `+RTS -l`. This will produce an eventlog called `hie.eventlog`.
3. Run `ghc-events-analyze` on the `hie.eventlog` file to produce the rendered SVG. Warning, this might take a while and produce a big SVG file.
The default options for `ghc-events-analyze` will produce quite a wide chart which is difficult to view. You can try using less buckets in order
to make the chart quicker to generate and faster to render.
```
ghc-events-analyze hie.eventlog -b 100
```
This support is similar to the logging capabilities [built into GHC](https://www.haskell.org/ghc/blog/20190924-eventful-ghc.html).

16
app/HieWrapper.hs
View File

@ -9,10 +9,9 @@ import Data.Semigroup
import Data.List
import Data.Foldable
import Data.Version (showVersion)
import qualified GhcMod.Monad as GM
import qualified GhcMod.Monad.Types as GM
import qualified GhcMod.Types as GM
import HIE.Bios
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.Cradle (findLocalCradle)
import Haskell.Ide.Engine.Options
import Haskell.Ide.Engine.Plugin.Base
import qualified Language.Haskell.LSP.Core as Core
@ -23,6 +22,7 @@ import System.Environment
import qualified System.Log.Logger as L
import System.Process
import System.Info
import System.FilePath
-- ---------------------------------------------------------------------
@ -73,15 +73,13 @@ run opts = do
logm $ "Current directory:" ++ d
logm $ "Operating system:" ++ os
-- Get the cabal directory from the ghc-mod cradle
(mcr,_) <- GM.runGhcModT GM.defaultOptions GM.cradle
dir <- case mcr of
Left err -> error (show err)
Right cr -> return $ GM.cradleRootDir cr
-- Get the cabal directory from the cradle
cradle <- findLocalCradle (d </> "File.hs")
let dir = cradleRootDir cradle
logm $ "Cradle directory:" ++ dir
setCurrentDirectory dir
ghcVersion <- getProjectGhcVersion
ghcVersion <- getProjectGhcVersion cradle
logm $ "Project GHC version:" ++ ghcVersion
let

42
app/MainHie.hs
View File

@ -17,6 +17,8 @@ import qualified Paths_haskell_ide_engine as Meta
import System.Directory
import System.Environment
import qualified System.Log.Logger as L
import HIE.Bios.Types
import System.IO
-- ---------------------------------------------------------------------
-- plugins
@ -24,10 +26,9 @@ import qualified System.Log.Logger as L
import Haskell.Ide.Engine.Plugin.ApplyRefact
import Haskell.Ide.Engine.Plugin.Base
import Haskell.Ide.Engine.Plugin.Brittany
import Haskell.Ide.Engine.Plugin.Build
import Haskell.Ide.Engine.Plugin.Example2
import Haskell.Ide.Engine.Plugin.GhcMod
import Haskell.Ide.Engine.Plugin.HaRe
import Haskell.Ide.Engine.Plugin.Bios
-- import Haskell.Ide.Engine.Plugin.HaRe
import Haskell.Ide.Engine.Plugin.Haddock
import Haskell.Ide.Engine.Plugin.HfaAlign
import Haskell.Ide.Engine.Plugin.Hoogle
@ -36,6 +37,7 @@ import Haskell.Ide.Engine.Plugin.Liquid
import Haskell.Ide.Engine.Plugin.Package
import Haskell.Ide.Engine.Plugin.Pragmas
import Haskell.Ide.Engine.Plugin.Floskell
import Haskell.Ide.Engine.Plugin.Generic
-- ---------------------------------------------------------------------
@ -50,16 +52,16 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins
[ applyRefactDescriptor "applyrefact"
, baseDescriptor "base"
, brittanyDescriptor "brittany"
, buildPluginDescriptor "build"
, ghcmodDescriptor "ghcmod"
, haddockDescriptor "haddock"
, hareDescriptor "hare"
-- , hareDescriptor "hare"
, hoogleDescriptor "hoogle"
, hsimportDescriptor "hsimport"
, liquidDescriptor "liquid"
, packageDescriptor "package"
, pragmasDescriptor "pragmas"
, floskellDescriptor "floskell"
, biosDescriptor "bios"
, genericDescriptor "generic"
]
examplePlugins =
[example2Descriptor "eg2"
@ -98,18 +100,14 @@ main = do
run :: GlobalOpts -> IO ()
run opts = do
hSetBuffering stderr LineBuffering
let mLogFileName = optLogFile opts
logLevel = if optDebugOn opts
then L.DEBUG
else L.INFO
Core.setupLogger mLogFileName ["hie"] logLevel
projGhcVersion <- getProjectGhcVersion
when (projGhcVersion /= hieGhcVersion) $
warningm $ "Mismatching GHC versions: Project is " ++ projGhcVersion
++ ", HIE is " ++ hieGhcVersion
Core.setupLogger mLogFileName ["hie", "hie-bios"] logLevel
origDir <- getCurrentDirectory
@ -117,20 +115,16 @@ run opts = do
progName <- getProgName
logm $ "Run entered for HIE(" ++ progName ++ ") " ++ version
d <- getCurrentDirectory
logm $ "Current directory:" ++ d
logm $ "Current directory:" ++ origDir
args <- getArgs
logm $ "args:" ++ show args
let vomitOptions = defaultOptions { boLogging = BlVomit}
let defaultOpts = if optGhcModVomit opts then vomitOptions else defaultOptions
-- Running HIE on projects with -Werror breaks most of the features since all warnings
-- will be treated with the same severity of type errors. In order to offer a more useful
-- experience, we make sure warnings are always reported as warnings by setting -Wwarn
biosOptions = defaultOpts { boGhcUserOptions = ["-Wwarn"] }
let initOpts = defaultCradleOpts { cradleOptsVerbosity = verbosity }
verbosity = if optBiosVerbose opts then Verbose else Silent
when (optGhcModVomit opts) $
logm "Enabling --vomit for ghc-mod. Output will be on stderr"
when (optBiosVerbose opts) $
logm "Enabling verbose mode for hie-bios. This option currently doesn't do anything."
when (optExamplePlugin opts) $
logm "Enabling Example2 plugin, will insert constant diagnostics etc."
@ -139,8 +133,8 @@ run opts = do
-- launch the dispatcher.
if optJson opts then do
scheduler <- newScheduler plugins' biosOptions
scheduler <- newScheduler plugins' initOpts
jsonStdioTransport scheduler
else do
scheduler <- newScheduler plugins' biosOptions
scheduler <- newScheduler plugins' initOpts
lspStdioTransport scheduler origDir plugins' (optCaptureFile opts)

6
cabal.project
View File

@ -2,13 +2,13 @@ packages:
./
./hie-plugin-api/
./submodules/HaRe
-- ./submodules/HaRe
./submodules/cabal-helper/
./submodules/ghc-mod/
./submodules/ghc-mod/core/
./submodules/ghc-mod/ghc-project-types
tests: true
package haskell-ide-engine
test-show-details: direct
write-ghc-environment-files: never

8
docs/Build.md
View File

@ -10,7 +10,7 @@ The design of the build system has the following main goals:
* works identically on every platform
* has minimal run-time dependencies:
- `stack`
- `stack` or `cabal`
- `git`
* is completely functional right after a simple `git clone` and after every `git pull`
* prevents certain build failures by either identifying a failed precondition (such as wrong `stack` version) or by performing the necessary steps so users can't forget them (such as invoking `git` to update submodules)
@ -38,7 +38,7 @@ Each `stack-*.yaml` contains references to packages in the submodules. Calling `
`hie` depends on a correct environment in order to function properly:
* `cabal-install`: This dependency is required by `hie` to handle correctly projects that are not `stack` based (without `stack.yaml`). You can install an appropriate version using `stack` with the `stack-install-cabal` target.
* `cabal-install`: This dependency is required by `hie` to handle correctly projects that are not `stack` based. You can install an appropriate version using `stack` with the `stack-install-cabal` target.
* The `hoogle` database: `hoogle generate` needs to be called with the most-recent `hoogle` version.
### Steps to build `hie`
@ -89,7 +89,7 @@ The final step is to configure the `hie` client to use a custom `hie-wrapper` sc
The `install.hs` script performs some checks to ensure that a correct installation is possible and provide meaningful error messages for known issues.
* `stack` needs to be up-to-date. Version `1.9.3` is required
* `cabal` needs to be up-to-date. Version `2.4.1.0` is required to *use* haskell-ide-engine until the pull request #1126 is merged. Unfortunately cabal version `3.0.0.0` is needed to *install* hie in windows systems but that inconsistence will be fixed by the mentioned pull request.
* `cabal` needs to be up-to-date. Version `3.0.0.0` is required for windows systems and `2.4.1.0` for other ones.
* `ghc-8.6.3` is broken on windows. Trying to install `hie-8.6.3` on windows is not possible.
* When the build fails, an error message, that suggests to remove `.stack-work` directory, is displayed.
@ -104,3 +104,5 @@ Currently, `stack` is needed even if you run the script with `cabal` to get the
Before the code in `install.hs` can be executed, `stack` installs a `GHC`, depending on the `resolver` field in `shake.yaml`. This is necessary if `install.hs` should be completely functional right after a fresh `git clone` without further configuration.
This may lead to an extra `GHC` to be installed by `stack` if not all versions of `haskell-ide-engine` are installed.
However, you always could change the resolver in `shake.yaml` to match the appropiate one.

50
haskell-ide-engine.cabal
View File

@ -1,5 +1,5 @@
name: haskell-ide-engine
version: 0.14.0.0
version: 1.0.0.0
synopsis: Provide a common engine to power any Haskell IDE
description: Please see README.md
homepage: http://github.com/githubuser/haskell-ide-engine#readme
@ -27,11 +27,10 @@ library
Haskell.Ide.Engine.Options
Haskell.Ide.Engine.Plugin.ApplyRefact
Haskell.Ide.Engine.Plugin.Brittany
Haskell.Ide.Engine.Plugin.Build
Haskell.Ide.Engine.Plugin.Example2
Haskell.Ide.Engine.Plugin.Floskell
Haskell.Ide.Engine.Plugin.GhcMod
Haskell.Ide.Engine.Plugin.HaRe
Haskell.Ide.Engine.Plugin.Bios
-- Haskell.Ide.Engine.Plugin.HaRe
Haskell.Ide.Engine.Plugin.Haddock
Haskell.Ide.Engine.Plugin.HfaAlign
Haskell.Ide.Engine.Plugin.Hoogle
@ -40,7 +39,9 @@ library
Haskell.Ide.Engine.Plugin.Package
Haskell.Ide.Engine.Plugin.Package.Compat
Haskell.Ide.Engine.Plugin.Pragmas
Haskell.Ide.Engine.Plugin.Generic
Haskell.Ide.Engine.Scheduler
Haskell.Ide.Engine.Support.FromHaRe
Haskell.Ide.Engine.Support.Fuzzy
Haskell.Ide.Engine.Support.HieExtras
Haskell.Ide.Engine.Transport.JsonStdio
@ -49,7 +50,7 @@ library
other-modules: Paths_haskell_ide_engine
build-depends: Cabal >= 1.22
, Diff
, HaRe
-- , HaRe
, aeson
, apply-refact
, async
@ -57,7 +58,7 @@ library
, brittany
, bytestring
, Cabal
, cabal-helper >= 0.8.0.4
, cabal-helper >= 1.0 && < 1.1
, containers
, data-default
, directory
@ -66,13 +67,11 @@ library
, fold-debounce
, ghc >= 8.0.1
, ghc-exactprint
, ghc-mod >= 5.9.0.0
, ghc-mod-core >= 5.9.0.0
, gitrev >= 1.1
, haddock-api
, haddock-library
, haskell-lsp == 0.18.*
, haskell-lsp-types == 0.18.*
, haskell-lsp == 0.19.*
, haskell-lsp-types == 0.19.*
, haskell-src-exts
, hie-plugin-api
, hoogle >= 5.0.13
@ -80,16 +79,15 @@ library
, hslogger
, lifted-async
, lens >= 4.15.2
, monad-control
, monoid-subclasses > 0.4
, mtl
, optparse-simple >= 0.0.3
, parsec
, process
, rope-utf16-splay >= 0.3.1.0
, safe
, sorted-list >= 0.2.1.0
, stm
, syb
, tagsoup
, text
, transformers
@ -98,6 +96,9 @@ library
, vector
, versions
, yaml >= 0.8.31
, hie-bios >= 0.3.2 && < 0.4.0
, bytestring-trie
, unliftio
, hlint >= 2.2.2
ghc-options: -Wall -Wredundant-constraints
@ -111,6 +112,8 @@ executable hie
other-modules: Paths_haskell_ide_engine
build-depends: base
, directory
, filepath
, hie-bios
, haskell-ide-engine
, haskell-lsp
, hie-plugin-api
@ -129,7 +132,8 @@ executable hie-wrapper
other-modules: Paths_haskell_ide_engine
build-depends: base
, directory
, ghc-mod-core
, filepath
, hie-bios
, haskell-ide-engine
, haskell-lsp
, hie-plugin-api
@ -148,6 +152,7 @@ library hie-test-utils
build-depends: base
, haskell-ide-engine
, haskell-lsp
, hie-bios
, hie-plugin-api
, aeson
, blaze-markup
@ -155,7 +160,6 @@ library hie-test-utils
, data-default
, directory
, filepath
, ghc-mod-core
, hslogger
, hspec
, hspec-core
@ -177,8 +181,8 @@ test-suite unit-test
ContextSpec
DiffSpec
ExtensibleStateSpec
GhcModPluginSpec
HaRePluginSpec
GenericPluginSpec
-- HaRePluginSpec
HooglePluginSpec
JsonSpec
LiquidSpec
@ -188,6 +192,7 @@ test-suite unit-test
build-tool-depends: cabal-helper:cabal-helper-main, hspec-discover:hspec-discover
build-depends: QuickCheck
, aeson
, ghc
, base
, bytestring
, containers
@ -196,7 +201,7 @@ test-suite unit-test
, free
, ghc
, haskell-ide-engine
, haskell-lsp-types == 0.18.*
, haskell-lsp-types == 0.19.*
, hie-test-utils
, hie-plugin-api
, hoogle > 5.0.11
@ -269,7 +274,8 @@ test-suite func-test
, FunctionalCodeActionsSpec
, FunctionalLiquidSpec
, FunctionalSpec
, HaReSpec
-- , HaReSpec
, HieBiosSpec
, HighlightSpec
, HoverSpec
, ProgressSpec
@ -283,10 +289,10 @@ test-suite func-test
, data-default
, directory
, filepath
, lsp-test >= 0.8.0.0
, lsp-test >= 0.9.0.0
, haskell-ide-engine
, haskell-lsp-types == 0.18.*
, haskell-lsp == 0.18.*
, haskell-lsp-types == 0.19.*
, haskell-lsp == 0.19.*
, hie-test-utils
, hie-plugin-api
, hspec
@ -309,8 +315,10 @@ test-suite wrapper-test
build-depends: base
, hspec
, directory
, filepath
, process
, haskell-ide-engine
, hie-plugin-api
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
if flag(pedantic)
ghc-options: -Werror

85
hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
module Haskell.Ide.Engine.ArtifactMap where
import Data.Maybe
@ -9,7 +8,7 @@ import qualified GHC
import GHC (TypecheckedModule)
import qualified SrcLoc as GHC
import qualified Var
import qualified GhcModCore as GM ( GhcRn, GhcTc, GhcPs )
import Haskell.Ide.Engine.GhcCompat
import Language.Haskell.LSP.Types
@ -42,57 +41,35 @@ genLocMap tm = names
renamed = fromJust $ GHC.tm_renamed_source tm
#if __GLASGOW_HASKELL__ > 710
names = IM.union names2 $ SYB.everything IM.union (IM.empty `SYB.mkQ` hsRecFieldT) typechecked
#else
names = names2
#endif
names2 = SYB.everything IM.union (IM.empty
#if __GLASGOW_HASKELL__ > 710
`SYB.mkQ` fieldOcc
`SYB.extQ` hsRecFieldN
`SYB.extQ` checker) renamed
#else
`SYB.mkQ` checker) renamed
#endif
checker (GHC.L (GHC.RealSrcSpan r) x) = IM.singleton (rspToInt r) x
checker _ = IM.empty
#if __GLASGOW_HASKELL__ >= 806
fieldOcc :: GHC.FieldOcc GM.GhcRn -> LocMap
fieldOcc (GHC.FieldOcc n (GHC.L (GHC.RealSrcSpan r) _)) = IM.singleton (rspToInt r) n
fieldOcc :: GHC.FieldOcc GhcRn -> LocMap
fieldOcc (FieldOccCompat n (GHC.L (GHC.RealSrcSpan r) _)) = IM.singleton (rspToInt r) n
fieldOcc _ = IM.empty
hsRecFieldN :: GHC.LHsExpr GM.GhcRn -> LocMap
hsRecFieldN (GHC.L _ (GHC.HsRecFld _ (GHC.Unambiguous n (GHC.L (GHC.RealSrcSpan r) _)) )) = IM.singleton (rspToInt r) n
hsRecFieldN :: GHC.LHsExpr GhcRn -> LocMap
hsRecFieldN (GHC.L _ (HsRecFldCompat (UnambiguousCompat n (GHC.L (GHC.RealSrcSpan r) _)) )) = IM.singleton (rspToInt r) n
hsRecFieldN _ = IM.empty
hsRecFieldT :: GHC.LHsExpr GM.GhcTc -> LocMap
hsRecFieldT (GHC.L _ (GHC.HsRecFld _ (GHC.Ambiguous n (GHC.L (GHC.RealSrcSpan r) _)) )) = IM.singleton (rspToInt r) (Var.varName n)
hsRecFieldT :: GHC.LHsExpr GhcTc -> LocMap
hsRecFieldT (GHC.L _ (HsRecFldCompat (AmbiguousCompat n (GHC.L (GHC.RealSrcSpan r) _)) )) = IM.singleton (rspToInt r) (Var.varName n)
hsRecFieldT _ = IM.empty
#elif __GLASGOW_HASKELL__ > 710
fieldOcc :: GHC.FieldOcc GM.GhcRn -> LocMap
fieldOcc (GHC.FieldOcc (GHC.L (GHC.RealSrcSpan r) _) n) = IM.singleton (rspToInt r) n
fieldOcc _ = IM.empty
hsRecFieldN :: GHC.LHsExpr GM.GhcRn -> LocMap
hsRecFieldN (GHC.L _ (GHC.HsRecFld (GHC.Unambiguous (GHC.L (GHC.RealSrcSpan r) _) n) )) = IM.singleton (rspToInt r) n
hsRecFieldN _ = IM.empty
hsRecFieldT :: GHC.LHsExpr GM.GhcTc -> LocMap
hsRecFieldT (GHC.L _ (GHC.HsRecFld (GHC.Ambiguous (GHC.L (GHC.RealSrcSpan r) _) n) )) = IM.singleton (rspToInt r) (Var.varName n)
hsRecFieldT _ = IM.empty
#endif
-- | Generates a ModuleMap of imported and exported modules names,
-- and the locations that they were imported/exported at.
genImportMap :: TypecheckedModule -> ModuleMap
genImportMap tm = moduleMap
where
(_, lImports, mlies, _) = fromJust $ GHC.tm_renamed_source tm
(lImports, mlies) = fromJust $ exportedSymbols tm
lies = map fst $ fromMaybe [] mlies
lies = fromMaybe [] mlies
moduleMap :: ModuleMap
moduleMap = foldl goImp IM.empty lImports `IM.union` foldl goExp IM.empty lies
@ -102,11 +79,7 @@ genImportMap tm = moduleMap
goImp acc _ = acc
goExp :: ModuleMap -> GHC.LIE name -> ModuleMap
#if __GLASGOW_HASKELL__ >= 806
goExp acc (GHC.L (GHC.RealSrcSpan r) (GHC.IEModuleContents _ lmn)) =
#else
goExp acc (GHC.L (GHC.RealSrcSpan r) (GHC.IEModuleContents lmn)) =
#endif
goExp acc (GHC.L (GHC.RealSrcSpan r) (IEModuleContentsCompat lmn)) =
IM.insert (rspToInt r) (GHC.unLoc lmn) acc
goExp acc _ = acc
@ -115,45 +88,23 @@ genImportMap tm = moduleMap
genDefMap :: TypecheckedModule -> DefMap
genDefMap tm = mconcat $ map (go . GHC.unLoc) decls
where
go :: GHC.HsDecl GM.GhcPs -> DefMap
go :: GHC.HsDecl GhcPs -> DefMap
-- Type signatures
#if __GLASGOW_HASKELL__ >= 806
go (GHC.SigD _ (GHC.TypeSig _ lns _)) =
#else
go (GHC.SigD (GHC.TypeSig lns _)) =
#endif
go (SigDCompat (TypeSigCompat lns _)) =
foldl IM.union mempty $ fmap go' lns
where go' (GHC.L (GHC.RealSrcSpan r) n) = IM.singleton (rspToInt r) n
go' _ = mempty
-- Definitions
#if __GLASGOW_HASKELL__ >= 806
go (GHC.ValD _ (GHC.FunBind _ (GHC.L (GHC.RealSrcSpan r) n) GHC.MG { GHC.mg_alts = llms } _ _)) =
#else
go (GHC.ValD (GHC.FunBind (GHC.L (GHC.RealSrcSpan r) n) GHC.MG { GHC.mg_alts = llms } _ _ _)) =
#endif
go (ValDCompat (FunBindCompat (GHC.L (GHC.RealSrcSpan r) n) (GHC.MG { GHC.mg_alts = llms }))) =
IM.insert (rspToInt r) n wheres
where
wheres = mconcat $ fmap (gomatch . GHC.unLoc) (GHC.unLoc llms)
gomatch GHC.Match { GHC.m_grhss = GHC.GRHSs { GHC.grhssLocalBinds = lbs } } =
golbs (GHC.unLoc lbs)
#if __GLASGOW_HASKELL__ >= 806
gomatch GHC.XMatch{} = error "GHC.XMatch"
gomatch (GHC.Match _ _ _ (GHC.XGRHSs _)) = error "GHC.XMatch"
#endif
gomatch (MatchCompat lbs) = golbs (GHC.unLoc lbs)
#if __GLASGOW_HASKELL__ >= 806
golbs (GHC.HsValBinds _ (GHC.ValBinds _ lhsbs lsigs)) =
#else
golbs (GHC.HsValBinds (GHC.ValBindsIn lhsbs lsigs)) =
#endif
#if __GLASGOW_HASKELL__ >= 806
foldl (\acc x -> IM.union acc (go $ GHC.ValD GHC.NoExt $ GHC.unLoc x)) mempty lhsbs
`mappend` foldl IM.union mempty (fmap (go . GHC.SigD GHC.NoExt . GHC.unLoc) lsigs)
#else
foldl (\acc x -> IM.union acc (go $ GHC.ValD $ GHC.unLoc x)) mempty lhsbs
`mappend` foldl IM.union mempty (fmap (go . GHC.SigD . GHC.unLoc) lsigs)
#endif
golbs (HsValBindsCompat (ValBindsCompat lhsbs lsigs)) =
foldl (\acc x -> IM.union acc (go $ ValDCompat $ GHC.unLoc x)) mempty lhsbs
`mappend` foldl IM.union mempty (fmap (go . SigDCompat . GHC.unLoc) lsigs)
golbs _ = mempty
go _ = mempty
decls = GHC.hsmodDecls $ GHC.unLoc $ GHC.pm_parsed_source $ GHC.tm_parsed_module tm
@ -164,7 +115,7 @@ rspToInt = uncurry IM.Interval . unpackRealSrcSpan
-- -- | Seaches for all the symbols at a point in the
-- -- given LocMap
-- getNamesAtPos :: Position -> LocMap -> [((Position,Position), GM.GhcRn)]
-- getNamesAtPos :: Position -> LocMap -> [((Position,Position), GhcRn)]
-- getNamesAtPos p im = map f $ IM.search p im
getArtifactsAtPos :: Position -> SourceMap a -> [(Range, a)]

42
hie-plugin-api/Haskell/Ide/Engine/Context.hs
View File

@ -2,8 +2,8 @@ module Haskell.Ide.Engine.Context where
import Data.Generics
import Language.Haskell.LSP.Types
import GHC
import qualified GhcModCore as GM (GhcPs) -- for GHC 8.2.2
import qualified GHC
import Haskell.Ide.Engine.GhcCompat (GhcPs) -- for GHC 8.2.2
import Haskell.Ide.Engine.PluginUtils
import Control.Applicative ( (<|>) )
@ -23,13 +23,13 @@ data Context = TypeContext
-- | Generates a map of where the context is a type and where the context is a value
-- i.e. where are the value decls and the type decls
getContext :: Position -> ParsedModule -> Maybe Context
getContext :: Position -> GHC.ParsedModule -> Maybe Context
getContext pos pm
| Just (L (RealSrcSpan r) modName) <- moduleHeader
| Just (GHC.L (GHC.RealSrcSpan r) modName) <- moduleHeader
, pos `isInsideRange` r
= Just (ModuleContext (moduleNameString modName))
= Just (ModuleContext (GHC.moduleNameString modName))
| Just (L (RealSrcSpan r) _) <- exportList
| Just (GHC.L (GHC.RealSrcSpan r) _) <- exportList
, pos `isInsideRange` r
= Just ExportContext
@ -42,21 +42,21 @@ getContext pos pm
| otherwise
= Nothing
where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
exportList = hsmodExports $ unLoc $ pm_parsed_source pm
imports = hsmodImports $ unLoc $ pm_parsed_source pm
where decl = GHC.hsmodDecls $ GHC.unLoc $ GHC.pm_parsed_source pm
moduleHeader = GHC.hsmodName $ GHC.unLoc $ GHC.pm_parsed_source pm
exportList = GHC.hsmodExports $ GHC.unLoc $ GHC.pm_parsed_source pm
imports = GHC.hsmodImports $ GHC.unLoc $ GHC.pm_parsed_source pm
go :: LHsDecl GM.GhcPs -> Maybe Context
go (L (RealSrcSpan r) SigD {})
go :: GHC.LHsDecl GhcPs -> Maybe Context
go (GHC.L (GHC.RealSrcSpan r) GHC.SigD {})
| pos `isInsideRange` r = Just TypeContext
| otherwise = Nothing
go (L (GHC.RealSrcSpan r) GHC.ValD {})
go (GHC.L (GHC.RealSrcSpan r) GHC.ValD {})
| pos `isInsideRange` r = Just ValueContext
| otherwise = Nothing
go _ = Nothing
goInline :: GHC.LHsType GM.GhcPs -> Maybe Context
goInline :: GHC.LHsType GhcPs -> Maybe Context
goInline (GHC.L (GHC.RealSrcSpan r) _)
| pos `isInsideRange` r = Just TypeContext
| otherwise = Nothing
@ -65,22 +65,22 @@ getContext pos pm
p `isInsideRange` r = sp <= p && p <= ep
where (sp, ep) = unpackRealSrcSpan r
importGo :: GHC.LImportDecl GM.GhcPs -> Maybe Context
importGo (L (RealSrcSpan r) impDecl)
importGo :: GHC.LImportDecl GhcPs -> Maybe Context
importGo (GHC.L (GHC.RealSrcSpan r) impDecl)
| pos `isInsideRange` r
= importInline importModuleName (ideclHiding impDecl)
= importInline importModuleName (GHC.ideclHiding impDecl)
<|> Just (ImportContext importModuleName)
| otherwise = Nothing
where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
where importModuleName = GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName impDecl
importGo _ = Nothing
importInline :: String -> Maybe (Bool, GHC.Located [GHC.LIE GM.GhcPs]) -> Maybe Context
importInline modName (Just (True, L (RealSrcSpan r) _))
importInline :: String -> Maybe (Bool, GHC.Located [GHC.LIE GhcPs]) -> Maybe Context
importInline modName (Just (True, GHC.L (GHC.RealSrcSpan r) _))
| pos `isInsideRange` r = Just $ ImportHidingContext modName
| otherwise = Nothing
importInline modName (Just (False, L (RealSrcSpan r) _))
importInline modName (Just (False, GHC.L (GHC.RealSrcSpan r) _))
| pos `isInsideRange` r = Just $ ImportListContext modName
| otherwise = Nothing
importInline _ _ = Nothing

677
hie-plugin-api/Haskell/Ide/Engine/Cradle.hs Normal file
View File

@ -0,0 +1,677 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
module Haskell.Ide.Engine.Cradle where
import HIE.Bios as BIOS
import HIE.Bios.Types as BIOS
import Haskell.Ide.Engine.MonadFunctions
import Distribution.Helper (Package, projectPackages, pUnits,
pSourceDir, ChComponentInfo(..),
unChModuleName, Ex(..), ProjLoc(..),
QueryEnv, mkQueryEnv, runQuery,
Unit, unitInfo, uiComponents,
ChEntrypoint(..))
import Distribution.Helper.Discover (findProjects, getDefaultDistDir)
import Data.Char (toLower)
import Data.Function ((&))
import Data.List (isPrefixOf, isInfixOf)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import Data.List (sortOn, find)
import Data.Maybe (listToMaybe, mapMaybe, isJust)
import Data.Ord (Down(..))
import Data.String (IsString(..))
import Data.Foldable (toList)
import Control.Exception (IOException, try)
import System.FilePath
import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
import System.Exit
-- | Find the cradle that the given File belongs to.
--
-- First looks for a "hie.yaml" file in the directory of the file
-- or one of its parents. If this file is found, the cradle
-- is read from the config. If this config does not comply to the "hie.yaml"
-- specification, an error is raised.
--
-- If no "hie.yaml" can be found, the implicit config is used.
-- The implicit config uses different heuristics to determine the type
-- of the project that may or may not be accurate.
findLocalCradle :: FilePath -> IO Cradle
findLocalCradle fp = do
cradleConf <- BIOS.findCradle fp
case cradleConf of
Just yaml -> BIOS.loadCradle yaml
Nothing -> cabalHelperCradle fp
-- | Check if the given cradle is a stack cradle.
-- This might be used to determine the GHC version to use on the project.
-- If it is a stack-cradle, we have to use `stack path --compiler-exe`
-- otherwise we may ask `ghc` directly what version it is.
isStackCradle :: Cradle -> Bool
isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None"])
. BIOS.actionName
. BIOS.cradleOptsProg
{- | Finds a Cabal v2-project, Cabal v1-project or a Stack project
relative to the given FilePath.
Cabal v2-project and Stack have priority over Cabal v1-project.
This entails that if a Cabal v1-project can be identified, it is
first checked whether there are Stack projects or Cabal v2-projects
before it is concluded that this is the project root.
Cabal v2-projects and Stack projects are equally important.
Due to the lack of user-input we have to guess which project it
should rather be.
This guessing has no guarantees and may change at any time.
=== Example:
Assume the following project structure:
/
└── Foo/
├── Foo.cabal
├── stack.yaml
├── cabal.project
├── src
│ └── Lib.hs
└── B/
├── B.cabal
└── src/
└── Lib2.hs
Assume the call @findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs"@.
We now want to know to which project "/Foo/B/src/Lib2.hs" belongs to
and what the projects root is. If we only do a naive search to find the
first occurrence of either "B.cabal", "stack.yaml", "cabal.project"
or "Foo.cabal", we might assume that the location of "B.cabal" marks
the project's root directory of which "/Foo/B/src/Lib2.hs" is part of.
However, there is also a "cabal.project" and "stack.yaml" in the parent
directory, which add the package "B" as a package.
So, the compilation of the package "B", and the file "src/Lib2.hs" in it,
does not only depend on the definitions in "B.cabal", but also
on "stack.yaml" and "cabal.project".
The project root is therefore "/Foo/".
Only if there is no "stack.yaml" or "cabal.project" in any of the ancestor
directories, it is safe to assume that "B.cabal" marks the root of the project.
Thus:
>>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs
Just (Ex (ProjLocStackYaml { plStackYaml = "/Foo/"}))
or
>>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs
Just (Ex (ProjLocV2File { plProjectDirV2 = "/Foo/"}))
In the given example, it is not guaranteed which project type is found,
it is only guaranteed that it will not identify the project
as a cabal v1-project.
Note that this will not return any project types for which the corresponding
build tool is not on the PATH. This is "stack" and "cabal" for stack and cabal
(both v1 and v2) projects respectively.
-}
findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc))
findCabalHelperEntryPoint fp = do
allProjs <- concat <$> mapM findProjects (ancestors (takeDirectory fp))
debugm $ "Cabal-Helper found these projects: " ++ show (map (\(Ex x) -> show x) allProjs)
-- We only want to return projects that we have the build tools installed for
isStackInstalled <- isJust <$> findExecutable "stack"
isCabalInstalled <- isJust <$> findExecutable "cabal"
let supportedProjs = filter (\x -> supported x isStackInstalled isCabalInstalled) allProjs
debugm $ "These projects have the build tools installed: " ++ show (map (\(Ex x) -> show x) supportedProjs)
case filter (\p -> isCabalNewProject p || isStackProject p) supportedProjs of
(x:_) -> return $ Just x
[] -> case filter isCabalOldProject supportedProjs of
(x:_) -> return $ Just x
[] -> return Nothing
where
supported :: (Ex ProjLoc) -> Bool -> Bool -> Bool
supported (Ex ProjLocStackYaml {}) stackInstalled _ = stackInstalled
supported (Ex ProjLocV2Dir {}) _ cabalInstalled = cabalInstalled
supported (Ex ProjLocV2File {}) _ cabalInstalled = cabalInstalled
supported (Ex ProjLocV1Dir {}) _ cabalInstalled = cabalInstalled
supported (Ex ProjLocV1CabalFile {}) _ cabalInstalled = cabalInstalled
isStackProject (Ex ProjLocStackYaml {}) = True
isStackProject _ = False
isCabalNewProject (Ex ProjLocV2Dir {}) = True
isCabalNewProject (Ex ProjLocV2File {}) = True
isCabalNewProject _ = False
isCabalOldProject (Ex ProjLocV1Dir {}) = True
isCabalOldProject (Ex ProjLocV1CabalFile {}) = True
isCabalOldProject _ = False
{- | Given a FilePath, find the cradle the FilePath belongs to.
Finds the Cabal Package the FilePath is most likely a part of
and creates a cradle whose root directory is the directory
of the package the File belongs to.
It is not required that the FilePath given actually exists. If it does not
exist or is not part of any of the packages in the project, a "None"-cradle is
produced.
See <https://github.com/mpickering/hie-bios> for what a "None"-cradle is.
The "None"-cradle can still be used to query for basic information, such as
the GHC version used to build the project. However, it can not be used to
load any of the files in the project.
== General Approach
Given a FilePath that we want to load, we need to create a cradle
that can compile and load the given FilePath.
In Cabal-Helper, there is no notion of a cradle, but a project
consists of multiple packages that contain multiple units.
Each unit may consist of multiple components.
A unit is the smallest part of code that Cabal (the library) can compile.
Examples are executables, libraries, tests or benchmarks are all units.
Each of this units has a name that is unique within a build-plan,
such as "exe:hie" which represents the executable of the Haskell IDE Engine.
In principle, a unit is what hie-bios considers to be a cradle.
However, to find out to which unit a FilePath belongs, we have to initialise
the unit, e.g. configure its dependencies and so on. When discovering a cradle
we do not want to pay for this upfront, but rather when we actually want to
load a Module in the project. Therefore, we only identify the package the
FilePath is part of and decide which unit to load when 'runCradle' is executed.
Thus, to find the options required to compile and load the given FilePath,
we have to do the following:
1. Identify the package that contains the FilePath (should be unique)
Happens in 'cabalHelperCradle'
2. Find the unit that that contains the FilePath (May be non-unique)
Happens in 'cabalHelperAction'
3. Find the component that exposes the FilePath (May be non-unique)
Happens in 'cabalHelperAction'
=== Identify the package that contains the FilePath
The function 'cabalHelperCradle' does the first step only.
It starts by querying Cabal-Helper to find the project's root.
See 'findCabalHelperEntryPoint' for details how this is done.
Once the root of the project is defined, we query Cabal-Helper for all packages
that are defined in the project and match by the packages source directory
which package the given FilePath is most likely to be a part of.
E.g. if the source directory of the package is the most concrete
prefix of the FilePath, the FilePath is in that package.
After the package is identified, we create a cradle where cradle's root
directory is set to the package's source directory. This is necessary,
because compiler options obtained from a component, are relative
to the source directory of the package the component is part of.
=== Find the unit that that contains the FilePath
In 'cabalHelperAction' we want to load a given FilePath, already knowing
which package the FilePath is part of. Now we obtain all Units that are part
of the package and match by the source directories (plural is intentional),
to which unit the given FilePath most likely belongs to. If no unit can be
obtained, e.g. for every unit, no source directory is a prefix of the FilePath,
we return an error code, since this is not allowed to happen.
If there are multiple matches, which is possible, we check whether any of the
components defined in the unit exposes or defines the given FilePath as a module.
=== Find the component that exposes the FilePath
A component defines the options that are necessary to compile a FilePath that
is in the component. It also defines which modules are in the component.
Therefore, we translate the given FilePath into a module name, relative to
the unit's source directory, and check if the module name is exposed by the
component. There is a special case, executables define a FilePath, for the
file that contains the 'main'-function, that is relative to the unit's source
directory.
After the component has been identified, we can actually retrieve the options
required to load and compile the given file.
== Examples
=== Mono-Repo
Assume the project structure:
/
└── Mono/
├── cabal.project
├── stack.yaml
├── A/
│ ├── A.cabal
│ └── Lib.hs
└── B/
├── B.cabal
└── Exe.hs
Currently, Haskell IDE Engine needs to know on startup which GHC version is
needed to compile the project. This information is needed to show warnings to
the user if the GHC version on the project does not agree with the GHC version
that was used to compile Haskell IDE Engine.
Therefore, the function 'findLocalCradle' is invoked with a dummy FilePath,
such as "/Mono/Lib.hs". Since there will be no package that contains this
dummy FilePath, the result will be a None-cradle.
Either
>>> findLocalCradle "/Mono/Lib.hs"
Cradle { cradleRootDir = "/Mono/", CradleAction { actionName = "Cabal-Helper-Stack-None", ..} }
or:
>>> findLocalCradle "/Mono/Lib.hs"
Cradle { cradleRootDir = "/Mono/", CradleAction { actionName = "Cabal-Helper-Cabal-V2-None", ..} }
The cradle result of this invocation is only used to obtain the GHC version,
which is safe, since it only checks if the cradle is a 'stack' project or
a 'cabal' project.
If we are trying to load the executable:
>>> findLocalCradle "/Mono/B/Exe.hs"
Cradle { cradleRootDir = "/Mono/B/", CradleAction { actionName = "Cabal-Helper-Cabal-V2", ..} }
we will detect correctly the compiler options, by first finding the appropriate
package, followed by traversing the units in the package and finding the
component that exposes the executable by FilePath.
=== No explicit executable folder
Assume the project structure:
/
└── Library/
├── cabal.project
├── stack.yaml
├── Library.cabal
└── src
├── Lib.hs
└── Exe.hs
There are different dependencies for the library "Lib.hs" and the
executable "Exe.hs". If we are trying to load the executable "src/Exe.hs"
we will correctly identify the executable unit, and correctly initialise
dependencies of "exe:Library".
It will be correct even if we load the unit "lib:Library" before
the "exe:Library" because the unit "lib:Library" does not expose
a module "Exe".
=== Sub package
Assume the project structure:
/
└── Repo/
├── cabal.project
├── stack.yaml
├── Library.cabal
├── src
| └── Lib.hs
└── SubRepo
├── SubRepo.cabal
└── Lib2.hs
When we try to load "/Repo/SubRepo/Lib2.hs", we need to identify root
of the project, which is "/Repo/" but set the root directory of the cradle
responsible to load "/Repo/SubRepo/Lib2.hs" to "/Repo/SubRepo", since
the compiler options obtained from Cabal-Helper are relative to the package
source directory, which is "/Repo/SubRepo".
-}
cabalHelperCradle :: FilePath -> IO Cradle
cabalHelperCradle file = do
projM <- findCabalHelperEntryPoint file
case projM of
Nothing -> do
errorm $ "Could not find a Project for file: " ++ file
cwd <- getCurrentDirectory
return
Cradle { cradleRootDir = cwd
, cradleOptsProg =
CradleAction { actionName = "Cabal-Helper-None"
, runCradle = \_ _ -> return CradleNone
}
}
Just (Ex proj) -> do
-- Find the root of the project based on project type.
let root = projectRootDir proj
-- Create a suffix for the cradle name.
-- Purpose is mainly for easier debugging.
let actionNameSuffix = projectSuffix proj
logm $ "Cabal-Helper dirs: " ++ show [root, file]
let dist_dir = getDefaultDistDir proj
env <- mkQueryEnv proj dist_dir
packages <- runQuery projectPackages env
-- Find the package the given file may belong to.
-- If it does not belong to any package, create a none-cradle.
-- We might want to find a cradle without actually loading anything.
-- Useful if we only want to determine a ghc version to use.
case packages `findPackageFor` file of
Nothing -> do
debugm $ "Could not find a package for the file: " ++ file
debugm
"This is perfectly fine if we only want to determine the GHC version."
return
Cradle { cradleRootDir = root
, cradleOptsProg =
CradleAction { actionName = "Cabal-Helper-"
++ actionNameSuffix
++ "-None"
, runCradle = \_ _ -> return CradleNone
}
}
Just realPackage -> do
debugm $ "Cabal-Helper cradle package: " ++ show realPackage
-- Field `pSourceDir` often has the form `<cwd>/./plugin`
-- but we only want `<cwd>/plugin`
normalisedPackageLocation <- canonicalizePath $ pSourceDir realPackage
debugm
$ "Cabal-Helper normalisedPackageLocation: "
++ normalisedPackageLocation
return
Cradle { cradleRootDir = normalisedPackageLocation
, cradleOptsProg =
CradleAction { actionName =
"Cabal-Helper-" ++ actionNameSuffix
, runCradle = \_ fp -> cabalHelperAction
env
realPackage
normalisedPackageLocation
fp
}
}
where
-- | Fix occurrences of "-i." to "-i<cradle-root-dir>"
-- Flags obtained from cabal-helper are relative to the package
-- source directory. This is less resilient to using absolute paths,
-- thus, we fix it here.
fixImportDirs :: FilePath -> String -> String
fixImportDirs base_dir arg =
if "-i" `isPrefixOf` arg
then let dir = drop 2 arg
-- the flag "-i" has special meaning.
in if not (null dir) && isRelative dir then ("-i" ++ base_dir </> dir)
else arg
else arg
-- | cradle Action to query for the ComponentOptions that are needed
-- to load the given FilePath.
-- This Function is not supposed to throw any exceptions and use
-- 'CradleLoadResult' to indicate errors.
cabalHelperAction :: QueryEnv v -- ^ Query Env created by 'mkQueryEnv'
-- with the appropriate 'distdir'
-> Package v -- ^ Package this cradle is part for.
-> FilePath -- ^ Root directory of the cradle
-- this action belongs to.
-> FilePath -- ^ FilePath to load, expected to be an absolute path.
-> IO (CradleLoadResult ComponentOptions)
cabalHelperAction env package root fp = do
-- Get all unit infos the given FilePath may belong to
let units = pUnits package
-- make the FilePath to load relative to the root of the cradle.
let relativeFp = makeRelative root fp
debugm $ "Relative Module FilePath: " ++ relativeFp
getComponent env (toList units) relativeFp
>>= \case
Just comp -> do
let fs' = getFlags comp
let fs = map (fixImportDirs root) fs'
let targets = getTargets comp relativeFp
let ghcOptions = fs ++ targets
debugm $ "Flags for \"" ++ fp ++ "\": " ++ show ghcOptions
debugm $ "Component Infos: " ++ show comp
return
$ CradleSuccess
ComponentOptions { componentOptions = ghcOptions
, componentDependencies = []
}
Nothing -> return
$ CradleFail
$ CradleError
(ExitFailure 2)
["Could not obtain flags for " ++ fp]
-- | Get the component the given FilePath most likely belongs to.
-- Lazily ask units whether the given FilePath is part of one of their
-- component's.
-- If a Module belongs to multiple components, it is not specified which
-- component will be loaded.
-- The given FilePath must be relative to the Root of the project
-- the given units belong to.
getComponent
:: QueryEnv pt -> [Unit pt] -> FilePath -> IO (Maybe ChComponentInfo)
getComponent _env [] _fp = return Nothing
getComponent env (unit : units) fp =
try (runQuery (unitInfo unit) env) >>= \case
Left (e :: IOException) -> do
warningm $ "Catching and swallowing an IOException: " ++ show e
warningm
$ "The Exception was thrown in the context of finding"
++ " a component for \""
++ fp
++ "\" in the unit: "
++ show unit
getComponent env units fp
Right ui -> do
let components = M.elems (uiComponents ui)
debugm $ "Unit Info: " ++ show ui
case find (fp `partOfComponent`) components of
Nothing -> getComponent env units fp
comp -> return comp
-- | Check whether the given FilePath is part of the Component.
-- A FilePath is part of the Component if and only if:
--
-- * One Component's 'ciSourceDirs' is a prefix of the FilePath
-- * The FilePath, after converted to a module name,
-- is a in the Component's Targets, or the FilePath is
-- the executable in the component.
--
-- The latter is achieved by making the FilePath relative to the 'ciSourceDirs'
-- and then replacing Path separators with ".".
-- To check whether the given FilePath is the executable of the Component,
-- we have to check whether the FilePath, including 'ciSourceDirs',
-- is part of the targets in the Component.
partOfComponent ::
-- | FilePath relative to the package root.
FilePath ->
-- | Component to check whether the given FilePath is part of it.
ChComponentInfo ->
Bool
partOfComponent fp' comp
| inTargets (ciSourceDirs comp) fp' (getTargets comp fp')
= True
| otherwise
= False
where
-- Check if the FilePath is in an executable or setup's main-is field
inMainIs :: FilePath -> Bool
inMainIs fp
| ChExeEntrypoint mainIs _ <- ciEntrypoints comp = mainIs == fp
| ChSetupEntrypoint mainIs <- ciEntrypoints comp = mainIs == fp
| otherwise = False
inTargets :: [FilePath] -> FilePath -> [String] -> Bool
inTargets sourceDirs fp targets
| Just relative <- relativeTo fp sourceDirs
= any (`elem` targets) [getModuleName relative, fp] || inMainIs relative
| otherwise
= False
getModuleName :: FilePath -> String
getModuleName fp = map
(\c -> if isPathSeparator c
then '.'
else c)
(dropExtension fp)
-- | Get the flags necessary to compile the given component.
getFlags :: ChComponentInfo -> [String]
getFlags = ciGhcOptions
-- | Get all Targets of a Component, since we want to load all components.
-- FilePath is needed for the special case that the Component is an Exe.
-- The Exe contains a Path to the Main which is relative to some entry
-- in 'ciSourceDirs'.
-- We monkey-patch this by supplying the FilePath we want to load,
-- which is part of this component, and select the 'ciSourceDir' we actually want.
-- See the Documentation of 'ciSourceDir' to why this contains multiple entries.
getTargets :: ChComponentInfo -> FilePath -> [String]
getTargets comp fp = case ciEntrypoints comp of
ChSetupEntrypoint {} -> []
ChLibEntrypoint { chExposedModules, chOtherModules }
-> map unChModuleName (chExposedModules ++ chOtherModules)
ChExeEntrypoint { chMainIs, chOtherModules }
-> [sourceDir </> chMainIs | Just sourceDir <- [sourceDirs]]
++ map unChModuleName chOtherModules
where
sourceDirs = find (`isFilePathPrefixOf` fp) (ciSourceDirs comp)
-- | For all packages in a project, find the project the given FilePath
-- belongs to most likely.
findPackageFor :: NonEmpty (Package pt) -> FilePath -> Maybe (Package pt)
findPackageFor packages fp = packages
& NonEmpty.toList
& sortOn (Down . pSourceDir)
& filter (\p -> pSourceDir p `isFilePathPrefixOf` fp)
& listToMaybe
projectRootDir :: ProjLoc qt -> FilePath
projectRootDir ProjLocV1CabalFile { plProjectDirV1 } = plProjectDirV1
projectRootDir ProjLocV1Dir { plProjectDirV1 } = plProjectDirV1
projectRootDir ProjLocV2File { plProjectDirV2 } = plProjectDirV2
projectRootDir ProjLocV2Dir { plProjectDirV2 } = plProjectDirV2
projectRootDir ProjLocStackYaml { plStackYaml } = takeDirectory plStackYaml
projectSuffix :: ProjLoc qt -> FilePath
projectSuffix ProjLocV1CabalFile {} = "Cabal-V1"
projectSuffix ProjLocV1Dir {} = "Cabal-V1-Dir"
projectSuffix ProjLocV2File {} = "Cabal-V2"
projectSuffix ProjLocV2Dir {} = "Cabal-V2-Dir"
projectSuffix ProjLocStackYaml {} = "Stack"
-- ----------------------------------------------------------------------------
--
-- Utility functions to manipulate FilePath's
--
-- ----------------------------------------------------------------------------
-- | Helper function to make sure that both FilePaths are normalised.
-- Checks whether the first FilePath is a Prefix of the second FilePath.
-- Intended usage:
--
-- >>> isFilePathPrefixOf "./src/" "./src/File.hs"
-- True
--
-- >>> isFilePathPrefixOf "./src" "./src/File.hs"
-- True
--
-- >>> isFilePathPrefixOf "./src/././" "./src/File.hs"
-- True
--
-- >>> isFilePathPrefixOf "./src" "./src-dir/File.hs"
-- False
isFilePathPrefixOf :: FilePath -> FilePath -> Bool
isFilePathPrefixOf dir fp = isJust $ stripFilePath dir fp
-- | Strip the given directory from the filepath if and only if
-- the given directory is a prefix of the filepath.
--
-- >>> stripFilePath "app" "app/File.hs"
-- Just "File.hs"
-- >>> stripFilePath "src" "app/File.hs"
-- Nothing
-- >>> stripFilePath "src" "src-dir/File.hs"
-- Nothing
-- >>> stripFilePath "." "src/File.hs"
-- Just "src/File.hs"
-- >>> stripFilePath "app/" "./app/Lib/File.hs"
-- Just "Lib/File.hs"
-- >>> stripFilePath "/app/" "./app/Lib/File.hs"
-- Nothing -- Nothing since '/app/' is absolute
-- >>> stripFilePath "/app" "/app/Lib/File.hs"
-- Just "Lib/File.hs"
stripFilePath :: FilePath -> FilePath -> Maybe FilePath
stripFilePath "." fp
| isRelative fp = Just fp
| otherwise = Nothing
stripFilePath dir' fp'
| Just relativeFpParts <- splitDir `stripPrefix` splitFp = Just (joinPath relativeFpParts)
| otherwise = Nothing
where
dir = normalise dir'
fp = normalise fp'
splitFp = splitPath fp
splitDir = splitPath dir
stripPrefix (x:xs) (y:ys)
| x `equalFilePath` y = stripPrefix xs ys
| otherwise = Nothing
stripPrefix [] ys = Just ys
stripPrefix _ [] = Nothing
-- | Obtain all ancestors from a given directory.
--
-- >>> ancestors "a/b/c/d/e"
-- [ "a/b/c/d/e", "a/b/c/d", "a/b/c", "a/b", "a", "." ]
--
-- >>> ancestors "/a/b/c/d/e"
-- [ "/a/b/c/d/e", "/a/b/c/d", "/a/b/c", "/a/b", "/a", "/" ]
--
-- >>> ancestors "/a/b.hs"
-- [ "/a/b.hs", "/a", "/" ]
--
-- >>> ancestors "a/b.hs"
-- [ "a/b.hs", "a", "." ]
--
-- >>> ancestors "a/b/"
-- [ "a/b" ]
ancestors :: FilePath -> [FilePath]
ancestors dir
| subdir `equalFilePath` dir = [dir]
| otherwise = dir : ancestors subdir
where
subdir = takeDirectory dir
-- | Assuming a FilePath "src/Lib/Lib.hs" and a list of directories
-- such as ["src", "app"], returns either the given FilePath
-- with a matching directory stripped away.
-- If there are multiple matches, e.g. multiple directories are a prefix
-- of the given FilePath, return the first match in the list.
-- Returns Nothing, if not a single
-- given directory is a prefix of the FilePath.
--
-- >>> relativeTo "src/Lib/Lib.hs" ["src"]
-- Just "Lib/Lib.hs"
--
-- >>> relativeTo "src/Lib/Lib.hs" ["app"]
-- Nothing
--
-- >>> relativeTo "src/Lib/Lib.hs" ["src", "src/Lib"]
-- Just "Lib/Lib.hs"
relativeTo :: FilePath -> [FilePath] -> Maybe FilePath
relativeTo file sourceDirs = listToMaybe
$ mapMaybe (`stripFilePath` file) sourceDirs
-- | Returns a user facing display name for the cradle type,
-- e.g. "Stack project" or "GHC session"
cradleDisplay :: IsString a => BIOS.Cradle -> a
cradleDisplay cradle = fromString result
where
result
| "stack" `isInfixOf` name = "Stack project"
| "cabal-v1" `isInfixOf` name = "Cabal (V1) project"
| "cabal" `isInfixOf` name = "Cabal project"
| "direct" `isInfixOf` name = "GHC session"
| "multi" `isInfixOf` name = "Multi Component project"
| otherwise = "project"
name = map toLower $ BIOS.actionName (BIOS.cradleOptsProg cradle)

342
hie-plugin-api/Haskell/Ide/Engine/Ghc.hs
View File

@ -1,10 +1,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
-- | This module provides the interface to GHC, mainly for loading
-- modules while updating the module cache.
@ -17,10 +15,14 @@ module Haskell.Ide.Engine.Ghc
, makeRevRedirMapFunc
) where
import Debug.Trace
import Bag
import Control.Monad.IO.Class
import Control.Monad ( when )
import Data.IORef
import qualified Data.Map.Strict as Map
import qualified Data.IntMap.Strict as IM
import Data.Semigroup ((<>), Semigroup)
import qualified Data.Set as Set
import qualified Data.Text as T
@ -28,34 +30,38 @@ import qualified Data.Aeson
import Data.Coerce
import ErrUtils
import qualified GhcModCore as GM ( withDynFlags
, gcatches, GHandler(..), ghcExceptionDoc
, mkErrStyle', renderGm
, getModulesGhc'
, GmlT(..), getMMappedFiles, GmState(..), GhcModT, cradle
, cabalResolvedComponents
, IOish, GhcModError(..), GmGhcSession(..), GhcModState(..), GmModuleGraph(..), Cradle(..), gmcHomeModuleGraph
, mkRevRedirMapFunc )
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import System.FilePath
import DynFlags
import GHC
import IOEnv as G
import HscTypes
import qualified HscTypes
import Outputable (renderWithStyle)
import Language.Haskell.LSP.Types ( NormalizedUri(..), toNormalizedUri )
-- ---------------------------------------------------------------------
import Haskell.Ide.Engine.GhcUtils
import Haskell.Ide.Engine.GhcCompat as Compat
--import qualified Haskell.Ide.Engine.Plugin.HieExtras as Hie
import Outputable hiding ((<>))
-- This function should be defined in HIE probably, nothing in particular
-- to do with BIOS
import qualified HIE.Bios.Ghc.Api as BIOS (withDynFlags)
import qualified HIE.Bios.Ghc.Load as BIOS
import System.Directory
import GhcProject.Types as GM
import GhcMake ( moduleGraphNodes )
import GhcMonad
newtype Diagnostics = Diagnostics (Map.Map NormalizedUri (Set.Set Diagnostic))
deriving (Show, Eq)
instance Semigroup Diagnostics where
Diagnostics d1 <> Diagnostics d2 = Diagnostics (d1 <> d2)
Diagnostics d1 <> Diagnostics d2 = Diagnostics (Map.unionWith Set.union d1 d2)
instance Monoid Diagnostics where
mappend = (<>)
@ -67,29 +73,20 @@ instance Data.Aeson.ToJSON Diagnostics where
type AdditionalErrs = [T.Text]
-- ---------------------------------------------------------------------
lspSev :: Severity -> DiagnosticSeverity
lspSev SevWarning = DsWarning
lspSev SevError = DsError
lspSev SevFatal = DsError
lspSev SevInfo = DsInfo
lspSev _ = DsInfo
-- ---------------------------------------------------------------------
-- type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
logDiag :: (FilePath -> FilePath) -> IORef AdditionalErrs -> IORef Diagnostics -> LogAction
logDiag rfm eref dref df _reason sev spn style msg = do
eloc <- srcSpan2Loc rfm spn
let msgTxt = T.pack $ renderWithStyle df msg style
case eloc of
Right (Location uri range) -> do
let update = Map.insertWith Set.union (toNormalizedUri uri) (Set.singleton diag)
diag = Diagnostic range (Just $ lspSev sev) Nothing (Just "ghcmod") msgTxt Nothing
modifyIORef' dref (\(Diagnostics d) -> Diagnostics $ update d)
Left _ -> do
modifyIORef' eref (msgTxt:)
return ()
lspSev :: WarnReason -> Severity -> DiagnosticSeverity
lspSev (Reason r) _
| r `elem` [ Opt_WarnDeferredTypeErrors
, Opt_WarnDeferredOutOfScopeVariables
]
= DsError
lspSev _ SevWarning = DsWarning
lspSev _ SevError = DsError
lspSev _ SevFatal = DsError
lspSev _ SevInfo = DsInfo
lspSev _ _ = DsInfo
-- ---------------------------------------------------------------------
@ -104,19 +101,19 @@ logDiag rfm eref dref df _reason sev spn style msg = do
srcErrToDiag :: MonadIO m
=> DynFlags
-> (FilePath -> FilePath)
-> SourceError -> m (Diagnostics, AdditionalErrs)
-> HscTypes.SourceError -> m (Diagnostics, AdditionalErrs)
srcErrToDiag df rfm se = do
debugm "in srcErrToDiag"
let errMsgs = bagToList $ srcErrorMessages se
let errMsgs = bagToList $ HscTypes.srcErrorMessages se
processMsg err = do
let sev = Just DsError
unqual = errMsgContext err
st = GM.mkErrStyle' df unqual
st = mkErrStyle df unqual
msgTxt = T.pack $ renderWithStyle df (pprLocErrMsg err) st
eloc <- srcSpan2Loc rfm $ errMsgSpan err
case eloc of
Right (Location uri range) ->
return $ Right (uri, Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing)
return $ Right (uri, Diagnostic range sev Nothing (Just "bios") msgTxt Nothing)
Left _ -> return $ Left msgTxt
processMsgs [] = return (Map.empty,[])
processMsgs (x:xs) = do
@ -130,131 +127,196 @@ srcErrToDiag df rfm se = do
(diags, errs) <- processMsgs errMsgs
return (Diagnostics diags, errs)
-- ---------------------------------------------------------------------
myWrapper :: GM.IOish m
-- | Run a Ghc action and capture any diagnostics and errors produced.
captureDiagnostics :: (MonadIO m, GhcMonad m)
=> (FilePath -> FilePath)
-> GM.GmlT m ()
-> GM.GmlT m (Diagnostics, AdditionalErrs)
myWrapper rfm action = do
-> m r
-> m (Diagnostics, AdditionalErrs, Maybe r)
captureDiagnostics rfm action = do
env <- getSession
diagRef <- liftIO $ newIORef mempty
diagRef <- liftIO $ newIORef $ Diagnostics mempty
errRef <- liftIO $ newIORef []
let setLogger df = df { log_action = logDiag rfm errRef diagRef }
setDeferTypedHoles = setGeneralFlag' Opt_DeferTypedHoles
-- Running HIE on projects with -Werror breaks most of the features since all warnings
-- will be treated with the same severity of type errors. In order to offer a more useful
-- experience, we make sure warnings are always reported as warnings by setting -Wwarn
unsetWErr df = unSetGeneralFlag' Opt_WarnIsError (emptyFatalWarningFlags df)
-- Dont report the missing module warnings. Before disabling this warning, it was
-- repeatedly shown to the user.
unsetMissingHomeModules = flip wopt_unset Opt_WarnMissingHomeModules
-- Dont get rid of comments while typechecking.
-- Important for various operations that work on a typechecked module.
setRawTokenStream = setGeneralFlag' Opt_KeepRawTokenStream
ghcErrRes :: String -> (Diagnostics, AdditionalErrs)
ghcErrRes msg = (mempty, [T.pack msg])
handlers = errorHandlers ghcErrRes (srcErrToDiag (hsc_dflags env) rfm )
action' = do
GM.withDynFlags (setLogger . setDeferTypedHoles) action
ghcErrRes msg = pure (mempty, [T.pack msg], Nothing)
to_diag x = do
(d1, e1) <- srcErrToDiag (HscTypes.hsc_dflags env) rfm x
diags <- liftIO $ readIORef diagRef
errs <- liftIO $ readIORef errRef
return (diags,errs)
GM.gcatches action' handlers
return (d1 <> diags, e1 ++ errs, Nothing)
-- ---------------------------------------------------------------------
handlers = errorHandlers ghcErrRes to_diag
errorHandlers :: (Monad m) => (String -> a) -> (SourceError -> m a) -> [GM.GHandler m a]
errorHandlers ghcErrRes renderSourceError = handlers
where
-- ghc throws GhcException, SourceError, GhcApiError and
-- IOEnvFailure. ghc-mod-core throws GhcModError.
handlers =
[ GM.GHandler $ \(ex :: GM.GhcModError) ->
return $ ghcErrRes (show ex)
, GM.GHandler $ \(ex :: IOEnvFailure) ->
return $ ghcErrRes (show ex)
, GM.GHandler $ \(ex :: GhcApiError) ->
return $ ghcErrRes (show ex)
, GM.GHandler $ \(ex :: SourceError) ->
renderSourceError ex
, GM.GHandler $ \(ex :: GhcException) ->
return $ ghcErrRes $ GM.renderGm $ GM.ghcExceptionDoc ex
, GM.GHandler $ \(ex :: IOError) ->
return $ ghcErrRes (show ex)
-- , GM.GHandler $ \(ex :: GM.SomeException) ->
-- return $ ghcErrRes (show ex)
]
foldDFlags :: (a -> DynFlags -> DynFlags) -> [a] -> DynFlags -> DynFlags
foldDFlags f xs x = foldr f x xs
-- ---------------------------------------------------------------------
setDeferTypeErrors =
foldDFlags (flip wopt_set) [Opt_WarnTypedHoles, Opt_WarnDeferredTypeErrors, Opt_WarnDeferredOutOfScopeVariables]
. foldDFlags setGeneralFlag' [Opt_DeferTypedHoles, Opt_DeferTypeErrors, Opt_DeferOutOfScopeVariables]
action' = do
r <- BIOS.withDynFlags (setRawTokenStream . unsetMissingHomeModules . setLogger . setDeferTypeErrors . unsetWErr) $
action
diags <- liftIO $ readIORef diagRef
errs <- liftIO $ readIORef errRef
return (diags,errs, Just r)
gcatches action' handlers
-- | Create a 'LogAction' which will be invoked by GHC when it tries to
-- write anything to `stdout`.
logDiag :: (FilePath -> FilePath) -> IORef AdditionalErrs -> IORef Diagnostics -> LogAction
-- type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
logDiag rfm eref dref df reason sev spn style msg = do
eloc <- srcSpan2Loc rfm spn
debugm $ "Diagnostics at Location: " <> show (spn, eloc)
let msgString = renderWithStyle df msg style
msgTxt = T.pack msgString
case sev of
-- These three verbosity levels are triggered by increasing verbosity.
-- Normally the verbosity is set to 0 when the session is initialised but
-- sometimes for debugging it is useful to override this and piping the messages
-- to the normal debugging framework means they just show up in the normal log.
SevOutput -> debugm msgString
SevDump -> debugm msgString
SevInfo -> debugm msgString
_ -> do
case eloc of
Right (Location uri range) -> do
let update = Map.insertWith Set.union (toNormalizedUri uri) l
where l = Set.singleton diag
diag = Diagnostic range (Just $ lspSev reason sev) Nothing (Just "bios") msgTxt Nothing
debugm $ "Writing diag " <> (show diag)
modifyIORef' dref (\(Diagnostics u) -> Diagnostics (update u))
Left _ -> do
debugm $ "Writing err " <> (show msgTxt)
modifyIORef' eref (msgTxt:)
return ()
-- | Load a module from a filepath into the cache, first check the cache
-- to see if it's already there.
setTypecheckedModule :: Uri -> IdeGhcM (IdeResult (Diagnostics, AdditionalErrs))
setTypecheckedModule uri =
pluginGetFile "setTypecheckedModule: " uri $ \fp -> do
fileMap <- GM.getMMappedFiles
debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap
rfm <- GM.mkRevRedirMapFunc
let
ghcErrRes msg = ((Diagnostics Map.empty, [T.pack msg]),Nothing,Nothing)
progTitle = "Typechecking " <> T.pack (takeFileName fp)
setTypecheckedModule uri = do
liftIO $ traceEventIO ("START typecheck" ++ show uri)
pluginGetFile "setTypecheckedModule: " uri $ \_fp -> do
debugm "setTypecheckedModule: before ghc-mod"
-- TODO:AZ: loading this one module may/should trigger loads of any
-- other modules which currently have a VFS entry. Need to make
-- sure that their diagnostics are reported, and their module
-- cache entries are updated.
-- TODO: Are there any hooks we can use to report back on the progress?
((Diagnostics diags', errs), mtm, mpm) <- withIndefiniteProgress progTitle NotCancellable $ GM.gcatches
(GM.getModulesGhc' (myWrapper rfm) fp)
(errorHandlers ghcErrRes (return . ghcErrRes . show))
debugm "setTypecheckedModule: after ghc-mod"
debugm "Loading file"
res <- setTypecheckedModule_load uri
liftIO $ traceEventIO ("STOP typecheck" ++ show uri)
return res
canonUri <- toNormalizedUri <$> canonicalizeUri uri
let diags = Map.insertWith Set.union canonUri Set.empty diags'
diags2 <- case (mpm,mtm) of
(Just pm, Nothing) -> do
debugm $ "setTypecheckedModule: Did get parsed module for: " ++ show fp
cacheModule fp (Left pm)
debugm "setTypecheckedModule: done"
return diags
-- Hacky, need to copy hs-boot file if one exists for a module
-- This is because the virtual file gets created at VFS-1234.hs and
-- then GHC looks for the boot file at VFS-1234.hs-boot
--
-- This strategy doesn't work if the user wants to edit the boot file but
-- not save it and expect the VFS to save them. However, I expect that HIE
-- already didn't deal with boot files correctly.
copyHsBoot :: FilePath -> FilePath -> IO ()
copyHsBoot fp mapped_fp = do
ex <- doesFileExist (fp <> "-boot")
when ex $ copyFile (fp <> "-boot") (mapped_fp <> "-boot")
(_, Just tm) -> do
debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp
sess <- fmap GM.gmgsSession . GM.gmGhcSession <$> GM.gmsGet
-- set the session before we cache the module, so that deferred
-- responses triggered by cacheModule can access it
modifyMTS (\s -> s {ghcSession = sess})
cacheModule fp (Right tm)
debugm "setTypecheckedModule: done"
return diags
loadFile :: (FilePath -> FilePath) -> (FilePath, FilePath)
-> IdeGhcM (Diagnostics, AdditionalErrs,
Maybe (Maybe TypecheckedModule, [TypecheckedModule]))
loadFile rfm t =
captureDiagnostics rfm (withProgress "loading" NotCancellable $ \f -> BIOS.loadFileWithMessage (Just $ toMessager f) t)
_ -> do
debugm $ "setTypecheckedModule: Didn't get typechecked or parsed module for: " ++ show fp
debugm $ "setTypecheckedModule: errs: " ++ show errs
-- | Actually load the module if it's not in the cache
setTypecheckedModule_load :: Uri -> IdeGhcM (IdeResult (Diagnostics, AdditionalErrs))
setTypecheckedModule_load uri =
pluginGetFile "setTypecheckedModule: " uri $ \fp -> do
debugm "setTypecheckedModule: before ghc-mod"
debugm "Loading file"
getPersistedFile uri >>= \case
Nothing -> return $ IdeResultOk (Diagnostics mempty, [])
Just mapped_fp -> do
liftIO $ copyHsBoot fp mapped_fp
rfm <- reverseFileMap
-- TODO:AZ: loading this one module may/should trigger loads of any
-- other modules which currently have a VFS entry. Need to make
-- sure that their diagnostics are reported, and their module
-- cache entries are updated.
-- TODO: Are there any hooks we can use to report back on the progress?
(Diagnostics diags', errs, mmods) <- loadFile rfm (fp, mapped_fp)
debugm "File, loaded"
canonUri <- toNormalizedUri <$> canonicalizeUri uri
let diags = Map.insertWith Set.union canonUri Set.empty diags'
debugm "setTypecheckedModule: after ghc-mod"
debugm ("Diags: " <> show diags')
let collapse Nothing = Nothing
collapse (Just (n, _xs)) = n
failModule fp
mtypechecked_module = collapse mmods
case mtypechecked_module of
Just _tm -> do
debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp
let sev = Just DsError
range = Range (Position 0 0) (Position 1 0)
msgTxt = T.unlines errs
let d = Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing
return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
-- set the session before we cache the module, so that deferred
-- responses triggered by cacheModule can access it
return $ IdeResultOk (Diagnostics diags2,errs)
Session sess <- GhcT pure
modifyMTS (\s -> s {ghcSession = Just sess})
cacheModules rfm [_tm]
debugm "setTypecheckedModule: done"
-- ---------------------------------------------------------------------
Nothing -> do
debugm $ "setTypecheckedModule: Didn't get typechecked or parsed module for: " ++ show fp
failModule fp
-- Turn any fatal exceptions thrown by GHC into a diagnostic for
-- this module so it appears somewhere permanent in the UI.
let diags2 =
case mtypechecked_module of
Nothing ->
let sev = Just DsError
range = Range (Position 0 0) (Position 1 0)
msgTxt = T.unlines errs
d = Diagnostic range sev Nothing (Just "bios") msgTxt Nothing
in Map.insertWith Set.union canonUri (Set.singleton d) diags
Just {} -> diags
return $ IdeResultOk (Diagnostics diags2,errs)
-- TODO: make this work for all components
cabalModuleGraphs :: IdeGhcM [GM.GmModuleGraph]
cabalModuleGraphs = doCabalModuleGraphs
where
doCabalModuleGraphs :: (GM.IOish m) => GM.GhcModT m [GM.GmModuleGraph]
doCabalModuleGraphs = do
crdl <- GM.cradle
case GM.cradleCabalFile crdl of
Just _ -> do
mcs <- GM.cabalResolvedComponents
let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs
return graph
Nothing -> return []
cabalModuleGraphs = do
mg <- getModuleGraph
let (graph, _) = moduleGraphNodes False (Compat.mgModSummaries mg)
msToModulePath ms =
case ml_hs_file (ms_location ms) of
Nothing -> []
Just fp -> [ModulePath mn fp]
where mn = moduleName (ms_mod ms)
nodeMap = IM.fromList [(node_key n,n) | n <- nodes]
nodes = verticesG graph
gmg = Map.fromList
[(mp,Set.fromList deps)
| node <- nodes
, mp <- msToModulePath (node_payload node)
, let int_deps = node_dependencies node
deps = [ d | i <- int_deps
, Just dep_node <- pure $ IM.lookup i nodeMap
, d <- msToModulePath (node_payload dep_node)
]
]
pure [GmModuleGraph gmg]
-- ---------------------------------------------------------------------
makeRevRedirMapFunc :: IdeGhcM (FilePath -> FilePath)
makeRevRedirMapFunc = make
where
make :: (GM.IOish m) => GM.GhcModT m (FilePath -> FilePath)
make = GM.mkRevRedirMapFunc
makeRevRedirMapFunc = reverseFileMap
-- ---------------------------------------------------------------------

551
hie-plugin-api/Haskell/Ide/Engine/GhcCompat.hs Normal file
View File

@ -0,0 +1,551 @@
-- Copyright 2017 Google Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -w #-}
-- | Module trying to expose a unified (or at least simplified) view of the GHC
-- AST changes across multiple compiler versions.
module Haskell.Ide.Engine.GhcCompat where
import Control.Arrow ((&&&))
import qualified Digraph
#if __GLASGOW_HASKELL__ >= 804
import qualified EnumSet as ES
import qualified HsExtension as GHC
#else
import qualified Data.IntSet as ES
#endif
import CmdLineParser
#if __GLASGOW_HASKELL__ >= 800
import Module (UnitId, unitIdString)
import qualified Bag
#else
import Module (Module, packageKeyString, modulePackageKey)
#endif
#if __GLASGOW_HASKELL__ < 802
import HsDecls (hs_instds)
#endif
#if __GLASGOW_HASKELL__ < 800
import GHC (PackageKey)
import SrcLoc (combineSrcSpans)
#endif
import HsBinds (HsBindLR(..), Sig(..), LHsBinds, abe_mono, abe_poly)
import HsDecls (ConDecl(..), TyClDecl(ClassDecl, DataDecl, SynDecl))
import HsExpr (HsExpr(..), HsRecordBinds)
import qualified HsTypes
import HsTypes (HsType(HsTyVar), LHsType)
import Id (Id)
import Name (Name)
import RdrName (RdrName)
import Outputable (Outputable)
import SrcLoc (Located, GenLocated(L), unLoc, getLoc)
import qualified GHC
import GHC hiding (GhcPs, GhcRn, GhcTc)
#if __GLASGOW_HASKELL__ < 804
type GhcPs = RdrName
type GhcRn = Name
type GhcTc = Id
type IdP a = a
#else
type GhcPs = GHC.GhcPs
type GhcRn = GHC.GhcRn
type GhcTc = GHC.GhcTc
#endif
#if __GLASGOW_HASKELL__ >= 800
showPackageName :: UnitId -> String
showPackageName = unitIdString
#else
showPackageName :: PackageKey -> String
showPackageName = packageKeyString
-- | Backfilling.
moduleUnitId :: Module -> PackageKey
moduleUnitId = modulePackageKey
#endif
-- | In GHC before 8.0.1 less things had Located wrappers, so no-op there.
-- Drops the Located on newer GHCs.
#if __GLASGOW_HASKELL__ >= 800
mayUnLoc :: Located a -> a
mayUnLoc = unLoc
#else
mayUnLoc :: a -> a
mayUnLoc = id
#endif
#if __GLASGOW_HASKELL__ < 802
-- | Backfilling.
hsGroupInstDecls = hs_instds
#endif
pattern RecordConCompat :: Located Id -> HsRecordBinds GhcTc -> HsExpr GhcTc
pattern RecordConCompat lConId recBinds <-
#if __GLASGOW_HASKELL__ >= 806
RecordCon _ lConId recBinds
#elif __GLASGOW_HASKELL__ >= 800
RecordCon lConId _ _ recBinds
#else
RecordCon lConId _ recBinds
#endif
pattern DataDeclCompat locName binders defn <-
#if __GLASGOW_HASKELL__ >= 806
DataDecl _ locName binders _ defn
#elif __GLASGOW_HASKELL__ >= 802
DataDecl locName binders _ defn _ _
#elif __GLASGOW_HASKELL__ >= 800
DataDecl locName binders defn _ _
#else
DataDecl locName binders defn _
#endif
pattern SynDeclCompat locName binders <-
#if __GLASGOW_HASKELL__ >= 806
SynDecl _ locName binders _ _
#elif __GLASGOW_HASKELL__ >= 802
SynDecl locName binders _ _ _
#else
SynDecl locName binders _ _
#endif
pattern FunBindCompat funId funMatches <-
#if __GLASGOW_HASKELL__ >= 806
FunBind _ funId funMatches _ _
#elif __GLASGOW_HASKELL__ >= 800
FunBind funId funMatches _ _ _
#else
FunBind funId _ funMatches _ _ _
#endif
pattern TypeSigCompat names ty <-
#if __GLASGOW_HASKELL__ >= 806
TypeSig _ names ty
#elif __GLASGOW_HASKELL__ >= 800
TypeSig names ty
#else
TypeSig names ty _
#endif
#if __GLASGOW_HASKELL__ >= 800
namesFromHsIbWc :: HsTypes.LHsSigWcType GhcRn -> [Name]
namesFromHsIbSig :: HsTypes.LHsSigType GhcRn -> [Name]
namesFromHsWC :: HsTypes.LHsWcType GhcRn -> [Name]
-- | Monomorphising type so uniplate is happier.
#if __GLASGOW_HASKELL__ >= 808
namesFromHsIbSig = HsTypes.hsib_ext
#elif __GLASGOW_HASKELL__ >= 806
namesFromHsIbSig = hsib_vars . HsTypes.hsib_ext
#else
namesFromHsIbSig = HsTypes.hsib_vars
#endif
#if __GLASGOW_HASKELL__ <= 804
namesFromHsWC = HsTypes.hswc_wcs
#else
namesFromHsWC = HsTypes.hswc_ext
#endif
namesFromHsIbWc =
-- No, can't use the above introduced names, because the types resolve
-- differently here. Type-level functions FTW.
#if __GLASGOW_HASKELL__ <= 800
HsTypes.hsib_vars
#elif __GLASGOW_HASKELL__ <= 804
HsTypes.hswc_wcs
#else
HsTypes.hswc_ext
#endif
#endif
data ClsSigBound = forall a. Outputable a => ClsSigBound ![Located Name] a
clsSigBound (TypeSigCompat ns ty) = Just (ClsSigBound ns ty)
#if __GLASGOW_HASKELL__ >= 806
clsSigBound (ClassOpSig _ _ ns ty)
#elif __GLASGOW_HASKELL__ >= 800
clsSigBound (ClassOpSig _ ns ty)
#endif
= Just (ClsSigBound ns ty)
-- TODO(robinpalotai): PatSynSig
clsSigBound _ = Nothing
pattern ClassDeclCompat locName binders sigs <-
#if __GLASGOW_HASKELL__ >= 806
ClassDecl _ _ locName binders _ _ sigs _ _ _ _
#elif __GLASGOW_HASKELL__ >= 802
ClassDecl _ locName binders _ _ sigs _ _ _ _ _
#else
ClassDecl _ locName binders _ sigs _ _ _ _ _
#endif
#if __GLASGOW_HASKELL__ >= 806
conDeclNames (ConDeclH98 { con_name = conName }) = [conName]
conDeclNames (ConDeclGADT { con_names = conNames }) = conNames
#elif __GLASGOW_HASKELL__ >= 800
conDeclNames (ConDeclH98 conName _ _ _ _) = [conName]
conDeclNames (ConDeclGADT conNames _ _) = conNames
#else
conDeclNames (ConDecl conNames _ _ _ _ _ _ _) = conNames
#endif
data AbsBindsKind = NormalAbs | SigAbs
deriving (Eq)
#if __GLASGOW_HASKELL__ >= 804
maybeAbsBinds :: HsBindLR a b
-> Maybe (LHsBinds a, [(IdP a, Maybe (IdP a))], AbsBindsKind)
#else
maybeAbsBinds :: HsBindLR a b
-> Maybe (LHsBinds a, [(a, Maybe a)], AbsBindsKind)
#endif
maybeAbsBinds abs@(AbsBinds { abs_exports = exports, abs_binds = binds}) =
let ids = map (abe_poly &&& (Just . abe_mono)) exports
binds_type =
#if __GLASGOW_HASKELL__ >= 804
if abs_sig abs then SigAbs else NormalAbs
#else
NormalAbs
#endif
in Just $! (binds, ids, binds_type)
#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 804
maybeAbsBinds (AbsBindsSig _ _ poly _ _ bind) =
let binds = Bag.unitBag bind
ids = [(poly, Nothing)]
in Just $! (binds, ids, SigAbs)
#endif
maybeAbsBinds _ = Nothing
pattern AbsBindsCompat binds ids abskind <-
(maybeAbsBinds -> Just (binds, ids, abskind))
-- | Represents various spans of 'instance' declarations separately.
data SplitInstType = SplitInstType
{ onlyClass :: !Name
, classAndInstance :: !(LHsType GhcRn)
-- ^ The location is properly set to the span of 'Cls Inst'
}
#if __GLASGOW_HASKELL__ >= 800
mySplitInstanceType :: HsTypes.LHsSigType GhcRn -> Maybe SplitInstType
mySplitInstanceType ty = do
let (_, body) = HsTypes.splitLHsForAllTy (HsTypes.hsSigType ty)
clsName <- HsTypes.getLHsInstDeclClass_maybe ty
Just $! SplitInstType
{ onlyClass = unLoc clsName
, classAndInstance = body
}
#else
mySplitInstanceType :: LHsType Name -> Maybe SplitInstType
mySplitInstanceType ty = do
(_, _, L clsL clsName, instLTys) <- HsTypes.splitLHsInstDeclTy_maybe ty
let clsInstTy = HsTypes.mkHsAppTys (L clsL (HsTypes.HsTyVar clsName))
instLTys
combinedLoc = foldr (combineSrcSpans . getLoc) clsL instLTys
Just $! SplitInstType
{ onlyClass = clsName
, classAndInstance = L combinedLoc clsInstTy
}
#endif
#if __GLASGOW_HASKELL__ >= 806
hsTypeVarName :: HsType GhcRn -> Maybe (Located Name)
hsTypeVarName (HsTyVar _ _ n) = Just $! n
#elif __GLASGOW_HASKELL__ >= 802
hsTypeVarName :: HsType GhcRn -> Maybe (Located Name)
hsTypeVarName (HsTyVar _ n) = Just $! n
#elif __GLASGOW_HASKELL__ >= 800
hsTypeVarName :: HsType Name -> Maybe (Located Name)
hsTypeVarName (HsTyVar n) = Just $! n
#else
hsTypeVarName :: HsType Name -> Maybe Name
hsTypeVarName (HsTyVar n) = Just $! n
#endif
hsTypeVarName _ = Nothing
getWarnMsg :: Warn -> String
#if __GLASGOW_HASKELL__ >= 804
getWarnMsg = unLoc . warnMsg
#else
getWarnMsg = unLoc
type Warn = Located String
#endif
#if __GLASGOW_HASKELL__ < 804
needsTemplateHaskellOrQQ = needsTemplateHaskell
#endif
mgModSummaries :: GHC.ModuleGraph -> [GHC.ModSummary]
#if __GLASGOW_HASKELL__ < 804
mgModSummaries = id
#else
mgModSummaries = GHC.mgModSummaries
#endif
#if __GLASGOW_HASKELL__ < 806
pattern HsForAllTyCompat binders <- HsForAllTy binders _
#else
pattern HsForAllTyCompat binders <- HsForAllTy _ binders _
#endif
#if __GLASGOW_HASKELL__ < 806
pattern UserTyVarCompat n <- UserTyVar n
pattern KindedTyVarCompat n <- KindedTyVar n _
#else
pattern UserTyVarCompat n <- UserTyVar _ n
pattern KindedTyVarCompat n <- KindedTyVar _ n _
#endif
pattern HsVarCompat v <-
#if __GLASGOW_HASKELL__ < 806
HsVar v
#else
HsVar _ v
#endif
pattern HsWrapCompat e <-
#if __GLASGOW_HASKELL__ < 806
HsWrap _ e
#else
HsWrap _ _ e
#endif
pattern HsParCompat e <-
#if __GLASGOW_HASKELL__ < 806
HsPar e
#else
HsPar _ e
#endif
pattern SectionLCompat e <-
#if __GLASGOW_HASKELL__ < 806
SectionL _ e
#else
SectionL _ _ e
#endif
pattern SectionRCompat e <-
#if __GLASGOW_HASKELL__ < 806
SectionR _ e
#else
SectionR _ _ e
#endif
pattern HsAppCompat f <-
#if __GLASGOW_HASKELL__ < 806
HsApp f _
#else
HsApp _ f _
#endif
pattern VarPatCompat v <-
#if __GLASGOW_HASKELL__ < 806
VarPat v
#else
VarPat _ v
#endif
#if __GLASGOW_HASKELL__ >= 802
pattern HsConLikeOutCompat v <-
#if __GLASGOW_HASKELL__ < 806
HsConLikeOut v
#elif __GLASGOW_HASKELL__
HsConLikeOut _ v
#endif
#endif
pattern RecordUpdCompat r dcs <-
#if __GLASGOW_HASKELL__ < 806
RecordUpd _ r dcs _ _ _
#else
RecordUpd (RecordUpdTc dcs _ _ _) _ r
#endif
pattern AsPatCompat asVar <-
#if __GLASGOW_HASKELL__ < 806
AsPat (L _ asVar) _
#else
AsPat _ (L _ asVar) _
#endif
pattern ClsInstDCompat v <-
#if __GLASGOW_HASKELL__ < 806
ClsInstD v
#else
ClsInstD _ v
#endif
pattern ClsInstDeclCompat lty lbinds <-
#if __GLASGOW_HASKELL__ < 806
ClsInstDecl lty lbinds _ _ _ _
#else
ClsInstDecl _ lty lbinds _ _ _ _
#endif
pattern FieldOccCompat n l <-
#if __GLASGOW_HASKELL__ < 806
FieldOcc l n
#else
FieldOcc n l
#endif
pattern UnambiguousCompat n l <-
#if __GLASGOW_HASKELL__ < 806
Unambiguous l n
#else
Unambiguous n l
#endif
pattern AmbiguousCompat n l <-
#if __GLASGOW_HASKELL__ < 806
Ambiguous l n
#else
Ambiguous n l
#endif
pattern HsRecFldCompat f <-
#if __GLASGOW_HASKELL__ < 806
HsRecFld f
#else
HsRecFld _ f
#endif
pattern IEModuleContentsCompat f <-
#if __GLASGOW_HASKELL__ < 806
IEModuleContents f
#else
IEModuleContents _ f
#endif
pattern HsValBindsCompat f <-
#if __GLASGOW_HASKELL__ < 806
HsValBinds f
#else
HsValBinds _ f
#endif
pattern ValBindsCompat f g <-
#if __GLASGOW_HASKELL__ < 806
ValBindsIn f g
#else
ValBinds _ f g
#endif
#if __GLASGOW_HASKELL__ < 806
pattern ValDCompat f <-
ValD f
where
ValDCompat f = ValD f
#else
pattern ValDCompat :: HsBind (GhcPass p) -> HsDecl (GhcPass p)
pattern ValDCompat f <-
ValD _ f
where
ValDCompat f = ValD NoExt f
#endif
#if __GLASGOW_HASKELL__ < 806
pattern SigDCompat f <-
SigD f
where
SigDCompat f = SigD f
#else
pattern SigDCompat :: Sig (GhcPass p) -> HsDecl (GhcPass p)
pattern SigDCompat f <-
SigD _ f
where
SigDCompat f = SigD NoExt f
#endif
{-# COMPLETE MatchCompat #-}
pattern MatchCompat ms <-
#if __GLASGOW_HASKELL__ < 806
((GHC.grhssLocalBinds . GHC.m_grhss) -> ms)
#else
(gomatch' -> ms)
gomatch' GHC.Match { GHC.m_grhss = GHC.GRHSs { GHC.grhssLocalBinds = lbs } } = lbs
gomatch' GHC.XMatch{} = error "GHC.XMatch"
gomatch' (GHC.Match _ _ _ (GHC.XGRHSs _)) = error "GHC.XMatch"
#endif
exportedSymbols :: GHC.TypecheckedModule -> Maybe ([LImportDecl GhcRn], Maybe [LIE GhcRn])
exportedSymbols tm =
case GHC.renamedSource tm of
Nothing -> Nothing
Just (_, limport, mlies, _) ->
#if __GLASGOW_HASKELL__ >= 804
Just (limport, fmap (map fst) mlies)
#else
Just (limport, mlies)
#endif
emptyFatalWarningFlags :: DynFlags -> DynFlags
emptyFatalWarningFlags df = df { fatalWarningFlags = ES.empty }
-- Abstract Digraph
node_key :: Digraph.Node key payload -> key
node_key n =
#if __GLASGOW_HASKELL__ >= 804
Digraph.node_key n
#else
let (_, key, _) = n
in key
#endif
node_payload :: Digraph.Node key payload -> payload
node_payload n =
#if __GLASGOW_HASKELL__ >= 804
Digraph.node_payload n
#else
let (payload, _, _) = n
in payload
#endif
node_dependencies :: Digraph.Node key payload -> [key]
node_dependencies n =
#if __GLASGOW_HASKELL__ >= 804
Digraph.node_dependencies n
#else
let (_, _, deps) = n
in deps
#endif
verticesG = Digraph.verticesG

46
hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs
View File

@ -8,9 +8,13 @@ import qualified Data.Map as Map
import Data.Dynamic (Dynamic)
import Data.Typeable (TypeRep)
import qualified GhcModCore as GM ( Cradle(..) )
import qualified HIE.Bios as BIOS
import qualified Data.Trie as T
import qualified Data.ByteString.Char8 as B
import GHC (TypecheckedModule, ParsedModule)
import GHC (TypecheckedModule, ParsedModule, HscEnv)
import Data.List
import Haskell.Ide.Engine.ArtifactMap
@ -74,17 +78,45 @@ getThingsAtPos cm pos ts =
-- ---------------------------------------------------------------------
-- The following to move into ghc-mod-core
class (Monad m) => HasGhcModuleCache m where
class Monad m => HasGhcModuleCache m where
getModuleCache :: m GhcModuleCache
setModuleCache :: GhcModuleCache -> m ()
modifyModuleCache :: (GhcModuleCache -> GhcModuleCache) -> m ()
emptyModuleCache :: GhcModuleCache
emptyModuleCache = GhcModuleCache Map.empty Map.empty
emptyModuleCache = GhcModuleCache T.empty Map.empty Nothing
data LookupCradleResult = ReuseCradle | LoadCradle CachedCradle | NewCradle FilePath
-- | Lookup for the given File if the module cache has a fitting Cradle.
-- Checks if the File belongs to the current Cradle and if it is,
-- the current Cradle can be reused for the given Module/File.
--
-- If the Module is part of another Cradle that has already been loaded,
-- return the Cradle.
-- Otherwise, a new Cradle for the given FilePath needs to be created.
--
-- After loading, the cradle needs to be set as the current Cradle
-- via 'setCurrentCradle' before the Cradle can be cached via 'cacheCradle'.
lookupCradle :: FilePath -> GhcModuleCache -> LookupCradleResult
lookupCradle fp gmc =
case currentCradle gmc of
Just (dirs, _c) | (any (\d -> d `isPrefixOf` fp) dirs) -> ReuseCradle
_ -> case T.match (cradleCache gmc) (B.pack fp) of
Just (_k, c, _suf) -> LoadCradle c
Nothing -> NewCradle fp
data CachedCradle = CachedCradle BIOS.Cradle HscEnv
instance Show CachedCradle where
show (CachedCradle x _) = show x
data GhcModuleCache = GhcModuleCache
{ cradleCache :: !(Map.Map FilePath GM.Cradle)
-- ^ map from dirs to cradles
{ cradleCache :: !(T.Trie CachedCradle)
-- ^ map from FilePath to cradles
, uriCaches :: !UriCaches
, currentCradle :: Maybe ([FilePath], BIOS.Cradle)
-- ^ The current cradle and which FilePath's it is
-- responsible for
} deriving (Show)
-- ---------------------------------------------------------------------

43
hie-plugin-api/Haskell/Ide/Engine/GhcUtils.hs Normal file
View File

@ -0,0 +1,43 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Haskell.Ide.Engine.GhcUtils where
import qualified Language.Haskell.LSP.Core as Core
import qualified HscMain as G
import Module
import HscTypes
import GHC
import IOEnv as G
import qualified Data.Text as T
import HIE.Bios.Types (CradleError)
import Haskell.Ide.Engine.PluginUtils (ErrorHandler(..))
-- Convert progress continuation to a messager
toMessager :: (Core.Progress -> IO ()) -> G.Messager
toMessager k _hsc_env (nk, n) _rc_reason ms =
let prog = Core.Progress (Just (fromIntegral nk/ fromIntegral n)) (Just mod_name)
mod_name = T.pack $ moduleNameString (moduleName (ms_mod ms))
in k prog
-- Handlers for each type of error that ghc can throw
errorHandlers :: (String -> m a) -> (HscTypes.SourceError -> m a) -> [ErrorHandler m a]
errorHandlers onGhcError onSourceError = handlers
where
-- ghc throws GhcException, SourceError, GhcApiError and
-- IOEnvFailure. hie-bios throws CradleError.
handlers =
[ ErrorHandler $ \(ex :: IOEnvFailure) ->
onGhcError (show ex)
, ErrorHandler $ \(ex :: GhcApiError) ->
onGhcError (show ex)
, ErrorHandler $ \(ex :: SourceError) ->
onSourceError ex
, ErrorHandler $ \(ex :: IOError) ->
onGhcError (show ex)
, ErrorHandler $ \(ex :: CradleError) ->
onGhcError (show ex)
, ErrorHandler $ \(ex :: GhcException) ->
onGhcError (showGhcException ex "")
]

310
hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs
View File

@ -4,24 +4,30 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskell.Ide.Engine.ModuleCache
( modifyCache
, withCradle
, ifCachedInfo
, withCachedInfo
, ifCachedModule
, ifCachedModuleM
, ifCachedModuleAndData
, withCachedModule
, withCachedModuleAndData
, deleteCachedModule
, failModule
, cacheModule
, cacheModules
, cacheInfoNoClear
, runActionWithContext
, ModuleCache(..)
) where
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
@ -31,73 +37,217 @@ import Data.Generics (Proxy(..), TypeRep, typeRep, typeOf)
import qualified Data.Map as Map
import Data.Maybe
import Data.Typeable (Typeable)
import Exception (ExceptionMonad)
import System.Directory
import System.FilePath
import qualified GhcModCore as GM ( findCradle'
, GmEnv(..), GmLog(..), GmlT(..), GmOut(..), cradle, options
, Cradle(..), GhcModEnv(..), MonadIO(..), Options(..)
, mkRevRedirMapFunc )
import qualified GHC as GHC
import qualified GHC
import qualified HscMain as GHC
import qualified Data.Aeson as Aeson
import qualified Data.Trie.Convenience as T
import qualified Data.Trie as T
import qualified Data.Text as Text
import qualified Data.Yaml as Yaml
import qualified HIE.Bios as BIOS
import qualified HIE.Bios.Ghc.Api as BIOS
import qualified Data.ByteString.Char8 as B
import Haskell.Ide.Engine.ArtifactMap
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
import Haskell.Ide.Engine.TypeMap
import Haskell.Ide.Engine.GhcModuleCache
import Haskell.Ide.Engine.MultiThreadState
import Haskell.Ide.Engine.PluginsIdeMonads
import Haskell.Ide.Engine.GhcCompat
import Haskell.Ide.Engine.GhcUtils
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.MonadFunctions
-- ---------------------------------------------------------------------
modifyCache :: (HasGhcModuleCache m) => (GhcModuleCache -> GhcModuleCache) -> m ()
modifyCache f = do
mc <- getModuleCache
setModuleCache (f mc)
modifyCache f = modifyModuleCache f
-- ---------------------------------------------------------------------
-- | Runs an IdeM action with the given Cradle
withCradle :: (GM.GmEnv m) => GM.Cradle -> m a -> m a
withCradle crdl =
GM.gmeLocal (\env -> env {GM.gmCradle = crdl})
-- | Run the given action in context and initialise a session with hie-bios.
-- If a context is given, the context is used to initialise a session for GHC.
-- The project "hie-bios" is used to find a Cradle and setup a GHC session
-- for diagnostics.
-- If no context is given, just execute the action.
-- Executing an action without context is useful, if you want to only
-- mutate ModuleCache or something similar without potentially loading
-- the whole GHC session for a component.
--
-- There are three possibilities for loading a cradle
-- 1. Load succeeds and we get a new cradle to execute the action in
-- 2. Load fails, so we report an error using IdeResultFail
-- 3. The bios reports CradleNone, which means we should completely ignore
-- the file.
--
-- In the third case, we
-- 1. Don't execute the action which we told to run, as we should behave as
-- though we know nothing about the file.
-- 2. Return the default value for the specific action.
runActionWithContext :: (MonadIde m, GHC.GhcMonad m, HasGhcModuleCache m, MonadBaseControl IO m)
=> GHC.DynFlags
-> Maybe FilePath -- ^ Context for the Action
-> a -- ^ Default value for none cradle
-> m a -- ^ Action to execute
-> m (IdeResult a) -- ^ Result of the action or error in
-- the context initialisation.
runActionWithContext _df Nothing _def action =
-- Cradle with no additional flags
-- dir <- liftIO $ getCurrentDirectory
--This causes problems when loading a later package which sets the
--packageDb
-- loadCradle df (BIOS.defaultCradle dir)
fmap IdeResultOk action
runActionWithContext df (Just uri) def action = do
mcradle <- getCradle uri
loadCradle df mcradle def action
-- ---------------------------------------------------------------------
-- | Runs an action in a ghc-mod Cradle found from the
-- directory of the given file. If no file is found
-- then runs the action in the default cradle.
-- Sets the current directory to the cradle root dir
-- in either case
runActionWithContext :: (GM.GmEnv m, GM.MonadIO m, HasGhcModuleCache m
, GM.GmLog m, MonadBaseControl IO m, ExceptionMonad m, GM.GmOut m)
=> Maybe FilePath -> m a -> m a
runActionWithContext Nothing action = do
crdl <- GM.cradle
liftIO $ setCurrentDirectory $ GM.cradleRootDir crdl
action
runActionWithContext (Just uri) action = do
crdl <- getCradle uri
liftIO $ setCurrentDirectory $ GM.cradleRootDir crdl
withCradle crdl action
-- | Get the Cradle that should be used for a given URI
getCradle :: (GM.GmEnv m, GM.MonadIO m, HasGhcModuleCache m, GM.GmLog m
, MonadBaseControl IO m, ExceptionMonad m, GM.GmOut m)
=> FilePath -> m GM.Cradle
-- | Load the Cradle based on the given DynFlags and Cradle lookup Result.
-- Reuses a Cradle if possible and sets up a GHC session for a new Cradle
-- if needed.
-- This function may take a long time to execute, since it potentially has
-- to set up the Session, including downloading all dependencies of a Cradle.
loadCradle :: forall a m . (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m
, MonadBaseControl IO m)
=> GHC.DynFlags
-> LookupCradleResult
-> a
-> m a
-> m (IdeResult a)
loadCradle _ ReuseCradle _def action = do
-- Since we expect this message to show up often, only show in debug mode
debugm "Reusing cradle"
IdeResultOk <$> action
loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) _def action = do
-- Reloading a cradle happens on component switch
logm $ "Switch to cradle: " ++ show crd
-- Cache the existing cradle
maybe (return ()) cacheCradle =<< (currentCradle <$> getModuleCache)
GHC.setSession env
setCurrentCradle crd
IdeResultOk <$> action
loadCradle iniDynFlags (NewCradle fp) def action = do
-- If this message shows up a lot in the logs, it is an indicator for a bug
logm $ "New cradle: " ++ fp
-- Cache the existing cradle
maybe (return ()) cacheCradle =<< (currentCradle <$> getModuleCache)
-- Now load the new cradle, accounting for hie.yaml parse errors
let parseErrorHandler = return . Left . Yaml.prettyPrintParseException
cradleRes <- liftIO $ catch (Right <$> findLocalCradle fp) parseErrorHandler
case cradleRes of
Right cradle -> do
logm $ "Found cradle: " ++ show cradle
withProgress ("Initializing " <> cradleDisplay cradle) NotCancellable (initialiseCradle cradle)
Left yamlErr ->
return $ IdeResultFail $ IdeError
{ ideCode = OtherError
, ideMessage = Text.pack $ "Couldn't parse hie.yaml: " <> yamlErr
, ideInfo = Aeson.Null
}
where
-- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`.
-- Reports its progress to the client.
initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m)
=> BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult a)
initialiseCradle cradle f = do
res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle
case res of
BIOS.CradleNone ->
-- Note: The action is not run if we are in the none cradle, we
-- just pretend the file doesn't exist.
return $ IdeResultOk def
BIOS.CradleFail err -> do
logm $ "GhcException on cradle initialisation: " ++ show err
return $ IdeResultFail $ IdeError
{ ideCode = OtherError
, ideMessage = Text.pack $ show err
, ideInfo = Aeson.Null
}
BIOS.CradleSuccess init_session -> do
-- Note that init_session contains a Hook to 'f'.
-- So, it can still provide Progress Reports.
-- Therefore, invocation of 'init_session' must happen
-- while 'f' is still valid.
liftIO (GHC.newHscEnv iniDynFlags) >>= GHC.setSession
liftIO $ setCurrentDirectory (BIOS.cradleRootDir cradle)
let onGhcError = return . Left
let onSourceError srcErr = do
logm $ "Source error on cradle initialisation: " ++ show srcErr
return $ Right BIOS.Failed
-- We continue setting the cradle in case the file has source errors
-- cause they will be reported to user by diagnostics
init_res <- gcatches
(Right <$> init_session)
(errorHandlers onGhcError onSourceError)
case init_res of
Left err -> do
logm $ "Ghc error on cradle initialisation: " ++ show err
return $ IdeResultFail $ IdeError
{ ideCode = OtherError
, ideMessage = Text.pack $ show err
, ideInfo = Aeson.Null
}
-- Note: Don't setCurrentCradle because we want to try to reload
-- it on a save whilst there are errors. Subsequent loads won't
-- be that slow, even though the cradle isn't cached because the
-- `.hi` files will be saved.
Right BIOS.Succeeded -> do
setCurrentCradle cradle
logm "Cradle set succesfully"
IdeResultOk <$> action
Right BIOS.Failed -> do
setCurrentCradle cradle
logm "Cradle did not load succesfully"
IdeResultOk <$> action
-- | Sets the current cradle for caching.
-- Retrieves the current GHC Module Graph, to find all modules
-- that belong to this cradle.
-- If the cradle does not load any module, it is responsible for an empty
-- list of Modules.
setCurrentCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => BIOS.Cradle -> m ()
setCurrentCradle cradle = do
mg <- GHC.getModuleGraph
let ps = mapMaybe (GHC.ml_hs_file . GHC.ms_location) (mgModSummaries mg)
debugm $ "Modules in the cradle: " ++ show ps
ps' <- liftIO $ mapM canonicalizePath ps
modifyCache (\s -> s { currentCradle = Just (ps', cradle) })
-- | Cache the given Cradle.
-- Caches the given Cradle together with all Modules this Cradle is responsible
-- for.
-- Via 'lookupCradle' it can be checked if a given FilePath is managed by
-- a any Cradle that has already been loaded.
cacheCradle :: (HasGhcModuleCache m, GHC.GhcMonad m) => ([FilePath], BIOS.Cradle) -> m ()
cacheCradle (ds, c) = do
env <- GHC.getSession
let cc = CachedCradle c env
new_map = T.fromList (map (, cc) (map B.pack ds))
modifyCache (\s -> s { cradleCache = T.unionWith (\a _ -> a) new_map (cradleCache s) })
-- | Get the Cradle that should be used for a given FilePath.
-- Looks up the cradle in the Module Cache and checks if the given
-- FilePath is managed by any already loaded Cradle.
getCradle :: (GHC.GhcMonad m, HasGhcModuleCache m)
=> FilePath -> m LookupCradleResult
getCradle fp = do
dir <- liftIO $ takeDirectory <$> canonicalizePath fp
mcache <- getModuleCache
let mcradle = (Map.lookup dir . cradleCache) mcache
case mcradle of
Just crdl ->
return crdl
Nothing -> do
opts <- GM.options
crdl <- GM.findCradle' (GM.optPrograms opts) dir
-- debugm $ "cradle cache miss for " ++ dir ++ ", generating cradle " ++ show crdl
modifyCache (\s -> s { cradleCache = Map.insert dir crdl (cradleCache s)})
return crdl
canon_fp <- liftIO $ canonicalizePath fp
mcache <- getModuleCache
return $ lookupCradle canon_fp mcache
ifCachedInfo :: (HasGhcModuleCache m, GM.MonadIO m) => FilePath -> a -> (CachedInfo -> m a) -> m a
ifCachedInfo :: (HasGhcModuleCache m, MonadIO m) => FilePath -> a -> (CachedInfo -> m a) -> m a
ifCachedInfo fp def callback = do
muc <- getUriCache fp
case muc of
@ -109,15 +259,18 @@ withCachedInfo fp def callback = deferIfNotCached fp go
where go (UriCacheSuccess uc) = callback (cachedInfo uc)
go UriCacheFailed = return def
ifCachedModule :: (HasGhcModuleCache m, MonadIO m, CacheableModule b) => FilePath -> a -> (b -> CachedInfo -> m a) -> m a
ifCachedModule fp def callback = ifCachedModuleM fp (return def) callback
-- | Calls the callback with the cached module for the provided path.
-- Otherwise returns the default immediately if there is no cached module
-- available.
-- If you need custom data, see also 'ifCachedModuleAndData'.
-- If you are in IdeDeferM and would like to wait until a cached module is available,
-- see also 'withCachedModule'.
ifCachedModule :: (HasGhcModuleCache m, MonadIO m, CacheableModule b)
=> FilePath -> a -> (b -> CachedInfo -> m a) -> m a
ifCachedModule fp def callback = do
ifCachedModuleM :: (HasGhcModuleCache m, MonadIO m, CacheableModule b)
=> FilePath -> m a -> (b -> CachedInfo -> m a) -> m a
ifCachedModuleM fp k callback = do
muc <- getUriCache fp
let x = do
res <- muc
@ -129,14 +282,14 @@ ifCachedModule fp def callback = do
UriCacheFailed -> Nothing
case x of
Just (ci, cm) -> callback cm ci
Nothing -> return def
Nothing -> k
-- | Calls the callback with the cached module and data for the provided path.
-- Otherwise returns the default immediately if there is no cached module
-- available.
-- If you are in IdeDeferM and would like to wait until a cached module is available,
-- see also 'withCachedModuleAndData'.
ifCachedModuleAndData :: forall a b m. (ModuleCache a, HasGhcModuleCache m, GM.MonadIO m, MonadMTState IdeState m)
ifCachedModuleAndData :: forall a b m. (ModuleCache a, HasGhcModuleCache m, MonadIO m, MonadMTState IdeState m)
=> FilePath -> b -> (GHC.TypecheckedModule -> CachedInfo -> a -> m b) -> m b
ifCachedModuleAndData fp def callback = do
muc <- getUriCache fp
@ -176,13 +329,13 @@ withCachedModuleAndData :: forall a b. (ModuleCache a)
withCachedModuleAndData fp def callback = deferIfNotCached fp go
where go (UriCacheSuccess (uc@(UriCache info _ (Just tm) dat))) =
lookupCachedData fp tm info dat >>= callback tm (cachedInfo uc)
go (UriCacheSuccess (UriCache _ _ Nothing _)) = wrap (Defer fp go)
go (UriCacheSuccess (UriCache { cachedTcMod = Nothing })) = wrap (Defer fp go)
go UriCacheFailed = return def
getUriCache :: (HasGhcModuleCache m, MonadIO m) => FilePath -> m (Maybe UriCacheResult)
getUriCache fp = do
uri' <- liftIO $ canonicalizePath fp
fmap (Map.lookup uri' . uriCaches) getModuleCache
canonical_fp <- liftIO $ canonicalizePath fp
fmap (Map.lookup canonical_fp . uriCaches) getModuleCache
deferIfNotCached :: FilePath -> (UriCacheResult -> IdeDeferM a) -> IdeDeferM a
deferIfNotCached fp cb = do
@ -191,10 +344,10 @@ deferIfNotCached fp cb = do
Just res -> cb res
Nothing -> wrap (Defer fp cb)
lookupCachedData :: forall a m. (HasGhcModuleCache m, MonadMTState IdeState m, GM.MonadIO m, Typeable a, ModuleCache a)
lookupCachedData :: forall a m. (HasGhcModuleCache m, MonadMTState IdeState m, MonadIO m, Typeable a, ModuleCache a)
=> FilePath -> GHC.TypecheckedModule -> CachedInfo -> (Map.Map TypeRep Dynamic) -> m a
lookupCachedData fp tm info dat = do
fp' <- liftIO $ canonicalizePath fp
canonical_fp <- liftIO $ canonicalizePath fp
let proxy :: Proxy a
proxy = Proxy
case Map.lookup (typeRep proxy) dat of
@ -202,7 +355,7 @@ lookupCachedData fp tm info dat = do
val <- cacheDataProducer tm info
let dat' = Map.insert (typeOf val) (toDyn val) dat
newUc = UriCache info (GHC.tm_parsed_module tm) (Just tm) dat'
modifyCache (\s -> s {uriCaches = Map.insert fp' (UriCacheSuccess newUc)
modifyCache (\s -> s {uriCaches = Map.insert canonical_fp (UriCacheSuccess newUc)
(uriCaches s)})
return val
@ -211,17 +364,26 @@ lookupCachedData fp tm info dat = do
Just val -> return val
Nothing -> error "impossible"
cacheModules :: (FilePath -> FilePath) -> [GHC.TypecheckedModule] -> IdeGhcM ()
cacheModules rfm ms = mapM_ go_one ms
where
go_one m = case get_fp m of
Just fp -> cacheModule (rfm fp) (Right m)
Nothing -> do
logm $ "Reverse File Map failed in cacheModules for FilePath: " ++ show (get_fp m)
return ()
get_fp = GHC.ml_hs_file . GHC.ms_location . GHC.pm_mod_summary . GHC.tm_parsed_module
-- | Saves a module to the cache and executes any deferred
-- responses waiting on that module.
cacheModule :: FilePath -> Either GHC.ParsedModule GHC.TypecheckedModule -> IdeGhcM ()
cacheModule uri modul = do
uri' <- liftIO $ canonicalizePath uri
rfm <- GM.mkRevRedirMapFunc
cacheModule :: FilePath -> (Either GHC.ParsedModule GHC.TypecheckedModule) -> IdeGhcM ()
cacheModule fp modul = do
canonical_fp <- liftIO $ canonicalizePath fp
rfm <- reverseFileMap
newUc <-
case modul of
Left pm -> do
muc <- getUriCache uri'
muc <- getUriCache canonical_fp
let defInfo = CachedInfo mempty mempty mempty mempty rfm return return
return $ case muc of
Just (UriCacheSuccess uc) ->
@ -234,17 +396,17 @@ cacheModule uri modul = do
_ -> UriCache defInfo pm Nothing mempty
Right tm -> do
typm <- GM.unGmlT $ genTypeMap tm
typm <- genTypeMap tm
let info = CachedInfo (genLocMap tm) typm (genImportMap tm) (genDefMap tm) rfm return return
pm = GHC.tm_parsed_module tm
return $ UriCache info pm (Just tm) mempty
let res = UriCacheSuccess newUc
modifyCache $ \gmc ->
gmc { uriCaches = Map.insert uri' res (uriCaches gmc) }
gmc { uriCaches = Map.insert canonical_fp res (uriCaches gmc) }
-- execute any queued actions for the module
runDeferredActions uri' res
runDeferredActions canonical_fp res
-- | Marks a module that it failed to load and triggers
-- any deferred responses waiting on it
@ -272,7 +434,9 @@ failModule fp = do
runDeferredActions :: FilePath -> UriCacheResult -> IdeGhcM ()
runDeferredActions uri res = do
actions <- fmap (fromMaybe [] . Map.lookup uri) (requestQueue <$> readMTS)
-- In general it is unsafe to read and then modify but the modification doesn't
-- capture the previously read state.
actions <- fromMaybe [] . Map.lookup uri . requestQueue <$> readMTS
-- remove queued actions
modifyMTS $ \s -> s { requestQueue = Map.delete uri (requestQueue s) }
@ -281,7 +445,7 @@ runDeferredActions uri res = do
-- | Saves a module to the cache without clearing the associated cache data - use only if you are
-- sure that the cached data associated with the module doesn't change
cacheInfoNoClear :: (GM.MonadIO m, HasGhcModuleCache m)
cacheInfoNoClear :: (MonadIO m, HasGhcModuleCache m)
=> FilePath -> CachedInfo -> m ()
cacheInfoNoClear uri ci = do
uri' <- liftIO $ canonicalizePath uri
@ -298,7 +462,7 @@ cacheInfoNoClear uri ci = do
updateCachedInfo UriCacheFailed = UriCacheFailed
-- | Deletes a module from the cache
deleteCachedModule :: (GM.MonadIO m, HasGhcModuleCache m) => FilePath -> m ()
deleteCachedModule :: (MonadIO m, HasGhcModuleCache m) => FilePath -> m ()
deleteCachedModule uri = do
uri' <- liftIO $ canonicalizePath uri
modifyCache (\s -> s { uriCaches = Map.delete uri' (uriCaches s) })
@ -312,7 +476,7 @@ deleteCachedModule uri = do
-- TODO: this name is confusing, given GhcModuleCache. Change it
class Typeable a => ModuleCache a where
-- | Defines an initial value for the state extension
cacheDataProducer :: (GM.MonadIO m, MonadMTState IdeState m)
cacheDataProducer :: (MonadIO m, MonadMTState IdeState m)
=> GHC.TypecheckedModule -> CachedInfo -> m a
instance ModuleCache () where

2
hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs
View File

@ -33,8 +33,6 @@ runMTState m s = do
class MonadIO m => MonadMTState s m | m -> s where
readMTS :: m s
modifyMTS :: (s -> s) -> m ()
writeMTS :: s -> m ()
writeMTS s = modifyMTS (const s)
instance MonadMTState s (MultiThreadState s) where
readMTS = readMTState

36
hie-plugin-api/Haskell/Ide/Engine/PluginApi.hs
View File

@ -38,7 +38,7 @@ module Haskell.Ide.Engine.PluginApi
, HIE.IdeState(..)
, HIE.IdeGhcM
, HIE.runIdeGhcM
, HIE.runIdeGhcMBare
, HIE.runActionWithContext
, HIE.IdeM
, HIE.runIdeM
, HIE.IdeDeferM
@ -54,18 +54,40 @@ module Haskell.Ide.Engine.PluginApi
, HIE.Diagnostics
, HIE.AdditionalErrs
, LSP.filePathToUri
, LSP.uriToFilePath
, LSP.Uri
, HIE.ifCachedModule
, HIE.CachedInfo(..)
, HIE.IdeResult(..)
-- * used for tests in HaRe
, HIE.BiosLogLevel(..)
, HIE.BiosOptions(..)
, HIE.defaultOptions
, BiosLogLevel
, BiosOptions
, defaultOptions
, HIE.BIOSVerbosity(..)
, HIE.CradleOpts(..)
, emptyIdePlugins
, emptyIdeState
) where
import qualified GhcProject.Types as GP
import qualified Haskell.Ide.Engine.Ghc as HIE
import qualified Haskell.Ide.Engine.GhcModuleCache as HIE (CachedInfo(..),HasGhcModuleCache(..))
import qualified Haskell.Ide.Engine.ModuleCache as HIE (ifCachedModule)
import qualified Haskell.Ide.Engine.GhcModuleCache as HIE (CachedInfo(..),HasGhcModuleCache(..),emptyModuleCache)
import qualified Haskell.Ide.Engine.ModuleCache as HIE (ifCachedModule,runActionWithContext )
import qualified Haskell.Ide.Engine.PluginsIdeMonads as HIE
import qualified Language.Haskell.LSP.Types as LSP ( filePathToUri )
import qualified Language.Haskell.LSP.Types as LSP ( filePathToUri, uriToFilePath, Uri )
import qualified HIE.Bios.Types as HIE
defaultOptions :: HIE.CradleOpts
defaultOptions = HIE.defaultCradleOpts
type BiosLogLevel = HIE.BIOSVerbosity
type BiosOptions = HIE.CradleOpts
emptyIdePlugins :: HIE.IdePlugins
emptyIdePlugins = HIE.IdePlugins mempty
emptyIdeState :: HIE.IdeState
emptyIdeState = HIE.IdeState HIE.emptyModuleCache mempty mempty Nothing

30
hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs
View File

@ -32,6 +32,9 @@ module Haskell.Ide.Engine.PluginUtils
, readVFS
, getRangeFromVFS
, rangeLinesFromVfs
, gcatches
, ErrorHandler(..)
) where
import Control.Monad.IO.Class
@ -45,19 +48,19 @@ import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe
import qualified GhcModCore as GM ( makeAbsolute' )
import FastString
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginsIdeMonads
import Haskell.Ide.Engine.GhcModuleCache
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.ArtifactMap
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Types.Capabilities
import qualified Language.Haskell.LSP.Types as J
import Prelude hiding (log)
import SrcLoc
import SrcLoc (SrcSpan(..), RealSrcSpan(..))
import Exception
import System.Directory
import System.FilePath
import qualified Data.Rope.UTF16 as Rope
-- ---------------------------------------------------------------------
@ -151,7 +154,7 @@ makeDiffResult :: FilePath -> T.Text -> (FilePath -> FilePath) -> IdeM Workspace
makeDiffResult orig new fileMap = do
origText <- liftIO $ T.readFile orig
let fp' = fileMap orig
fp <- liftIO $ GM.makeAbsolute' fp'
fp <- liftIO $ makeAbsolute fp'
diffText (filePathToUri fp,origText) new IncludeDeletions
-- | A version of 'makeDiffResult' that has does not insert any deletions
@ -159,7 +162,7 @@ makeAdditiveDiffResult :: FilePath -> T.Text -> (FilePath -> FilePath) -> IdeM W
makeAdditiveDiffResult orig new fileMap = do
origText <- liftIO $ T.readFile orig
let fp' = fileMap orig
fp <- liftIO $ GM.makeAbsolute' fp'
fp <- liftIO $ makeAbsolute fp'
diffText (filePathToUri fp,origText) new SkipDeletions
-- | Generate a 'WorkspaceEdit' value from a pair of source Text
@ -275,7 +278,7 @@ readVFS :: (MonadIde m, MonadIO m) => Uri -> m (Maybe T.Text)
readVFS uri = do
mvf <- getVirtualFile uri
case mvf of
Just (VirtualFile _ txt) -> return $ Just (Rope.toText txt)
Just vf -> return $ Just (virtualFileText vf)
Nothing -> return Nothing
getRangeFromVFS :: (MonadIde m, MonadIO m) => Uri -> Range -> m (Maybe T.Text)
@ -285,4 +288,15 @@ getRangeFromVFS uri rg = do
Just vfs -> return $ Just $ rangeLinesFromVfs vfs rg
Nothing -> return Nothing
-- ---------------------------------------------------------------------
-- Error catching utilities
data ErrorHandler m a = forall e . Exception e => ErrorHandler (e -> m a)
gcatches :: forall m a . (MonadIO m, ExceptionMonad m) => m a -> [ErrorHandler m a] -> m a
gcatches act handlers = gcatch act h
where
h :: SomeException -> m a
h e = foldr (\(ErrorHandler hand) me -> maybe me hand (fromException e)) (liftIO $ throw e) handlers

237
hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveAnyClass #-}
@ -10,7 +9,11 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
-- | IdeGhcM and associated types
module Haskell.Ide.Engine.PluginsIdeMonads
@ -48,7 +51,6 @@ module Haskell.Ide.Engine.PluginsIdeMonads
, IdeState(..)
, IdeGhcM
, runIdeGhcM
, runIdeGhcMBare
, IdeM
, runIdeM
, IdeDeferM
@ -61,6 +63,10 @@ module Haskell.Ide.Engine.PluginsIdeMonads
, getPlugins
, withProgress
, withIndefiniteProgress
, persistVirtualFile'
, getPersistedFile
, reverseFileMap
, withMappedFile
, Core.Progress(..)
, Core.ProgressCancellable(..)
-- ** Lifting
@ -88,27 +94,22 @@ module Haskell.Ide.Engine.PluginsIdeMonads
, PublishDiagnosticsParams(..)
, List(..)
, FormattingOptions(..)
-- * Options
, BiosLogLevel(..)
, BiosOptions(..)
, defaultOptions
, mkGhcModOptions
)
where
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Free
import Control.Monad.Trans.Control
import Control.Monad.Base
import UnliftIO
import Control.Applicative
import Data.Aeson hiding (defaultOptions)
import qualified Data.ConstrainedDynamic as CD
import Data.Default
import qualified Data.List as List
import Data.Dynamic ( Dynamic )
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid ( (<>) )
@ -117,15 +118,12 @@ import qualified Data.Text as T
import Data.Typeable ( TypeRep
, Typeable
)
import qualified GhcModCore as GM ( GhcModT, runGhcModT, GmlT(..), gmlGetSession, gmlSetSession
, MonadIO(..), GmLogLevel(..), Options(..), defaultOptions, OutputOpts(..) )
import System.Directory
import GhcMonad
import qualified HIE.Bios.Ghc.Api as BIOS
import GHC.Generics
import GHC ( HscEnv )
import qualified DynFlags as GHC
import qualified GHC as GHC
import qualified HscTypes as GHC
import Exception
import Haskell.Ide.Engine.Compat
import Haskell.Ide.Engine.Config
@ -343,28 +341,14 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c)
-- Monads
-- ---------------------------------------------------------------------
-- | IdeM that allows for interaction with the ghc-mod session
type IdeGhcM = GM.GhcModT IdeM
-- | IdeM that allows for interaction with the Ghc session
type IdeGhcM = GhcT IdeM
-- | Run an IdeGhcM with Cradle found from the current directory
runIdeGhcM :: BiosOptions -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
runIdeGhcM biosOptions plugins mlf stateVar f = do
runIdeGhcM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
runIdeGhcM plugins mlf stateVar f = do
env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
let ghcModOptions = mkGhcModOptions biosOptions
(eres, _) <- flip runReaderT stateVar $ flip runReaderT env $ GM.runGhcModT ghcModOptions f
case eres of
Left err -> liftIO $ throwIO err
Right res -> return res
-- | Run an IdeGhcM in an external context (e.g. HaRe), with no plugins or LSP functions
runIdeGhcMBare :: BiosOptions -> IdeGhcM a -> IO a
runIdeGhcMBare biosOptions f = do
let
plugins = IdePlugins Map.empty
mlf = Nothing
initialState = IdeState emptyModuleCache Map.empty Map.empty Nothing
stateVar <- newTVarIO initialState
runIdeGhcM biosOptions plugins mlf stateVar f
flip runReaderT stateVar $ flip runReaderT env $ BIOS.withGhcT f
-- | A computation that is deferred until the module is cached.
-- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed
@ -398,7 +382,7 @@ instance MonadIde IdeDeferM where
getIdeEnv = lift ask
instance MonadIde IdeGhcM where
getIdeEnv = lift $ lift ask
getIdeEnv = lift ask
getRootPath :: MonadIde m => m (Maybe FilePath)
getRootPath = do
@ -414,6 +398,40 @@ getVirtualFile uri = do
Just lf -> liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri)
Nothing -> return Nothing
-- | Worker function for persistVirtualFile without monad constraints.
--
-- Persist a virtual file as a temporary file in the filesystem.
-- If the virtual file associated to the given uri does not exist, Nothing
-- is returned.
persistVirtualFile' :: Core.LspFuncs Config -> Uri -> IO (Maybe FilePath)
persistVirtualFile' lf uri = Core.persistVirtualFileFunc lf (toNormalizedUri uri)
reverseFileMap :: (MonadIde m, MonadIO m) => m (FilePath -> FilePath)
reverseFileMap = do
mlf <- ideEnvLspFuncs <$> getIdeEnv
case mlf of
Just lf -> liftIO $ Core.reverseFileMapFunc lf
Nothing -> return id
-- | Get the location of the virtual file persisted to the file system associated
-- to the given Uri.
getPersistedFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe FilePath)
getPersistedFile uri = do
mlf <- ideEnvLspFuncs <$> getIdeEnv
case mlf of
Just lf -> liftIO $ persistVirtualFile' lf uri
Nothing -> return $ uriToFilePath uri
-- | Execute an action on the temporary file associated to the given FilePath.
-- If the file is not in the current Virtual File System, the given action is not executed
-- and instead returns the default value.
withMappedFile :: (MonadIde m, MonadIO m) => FilePath -> m a -> (FilePath -> m a) -> m a
withMappedFile fp m k = do
canon <- liftIO $ canonicalizePath fp
getPersistedFile (filePathToUri canon) >>= \case
Just fp' -> k fp'
Nothing -> m
getConfig :: (MonadIde m, MonadIO m) => m Config
getConfig = do
mlf <- ideEnvLspFuncs <$> getIdeEnv
@ -459,19 +477,19 @@ withIndefiniteProgress t c f = do
data IdeState = IdeState
{ moduleCache :: !GhcModuleCache
-- | A queue of requests to be performed once a module is loaded
, requestQueue :: Map.Map FilePath [UriCacheResult -> IdeM ()]
, requestQueue :: !(Map.Map FilePath [UriCacheResult -> IdeM ()])
, extensibleState :: !(Map.Map TypeRep Dynamic)
, ghcSession :: Maybe (IORef HscEnv)
, ghcSession :: !(Maybe (IORef HscEnv))
}
instance MonadMTState IdeState IdeGhcM where
readMTS = lift $ lift $ lift readMTS
modifyMTS = lift . lift . lift . modifyMTS
instance MonadMTState IdeState IdeDeferM where
readMTS = lift $ lift readMTS
modifyMTS = lift . lift . modifyMTS
instance MonadMTState IdeState IdeDeferM where
readMTS = lift readMTS
modifyMTS = lift . modifyMTS
instance MonadMTState IdeState IdeM where
readMTS = lift readMTS
modifyMTS = lift . modifyMTS
@ -479,40 +497,28 @@ instance MonadMTState IdeState IdeM where
class (Monad m) => LiftsToGhc m where
liftToGhc :: m a -> IdeGhcM a
instance GM.MonadIO IdeDeferM where
liftIO = liftIO
instance LiftsToGhc IdeM where
liftToGhc = lift . lift
liftToGhc = lift
instance LiftsToGhc IdeGhcM where
liftToGhc = id
instance HasGhcModuleCache IdeGhcM where
getModuleCache = lift $ lift getModuleCache
setModuleCache = lift . lift . setModuleCache
getModuleCache = lift getModuleCache
modifyModuleCache = lift . modifyModuleCache
instance HasGhcModuleCache IdeDeferM where
getModuleCache = lift getModuleCache
setModuleCache = lift . setModuleCache
modifyModuleCache = lift . modifyModuleCache
instance HasGhcModuleCache IdeM where
getModuleCache = do
tvar <- lift ask
state <- liftIO $ readTVarIO tvar
state <- readTVarIO tvar
return (moduleCache state)
setModuleCache !mc = do
modifyModuleCache f = do
tvar <- lift ask
liftIO $ atomically $ modifyTVar' tvar (\st -> st { moduleCache = mc })
-- ---------------------------------------------------------------------
instance GHC.HasDynFlags IdeGhcM where
getDynFlags = GHC.hsc_dflags <$> GHC.getSession
instance GHC.GhcMonad IdeGhcM where
getSession = GM.unGmlT GM.gmlGetSession
setSession env = GM.unGmlT (GM.gmlSetSession env)
atomically $ modifyTVar' tvar (\st -> st { moduleCache = f (moduleCache st) })
-- ---------------------------------------------------------------------
-- Results
@ -586,44 +592,83 @@ data IdeError = IdeError
instance ToJSON IdeError
instance FromJSON IdeError
-- ---------------------------------------------------------------------
-- Probably need to move this some time, but hitting import cycle issues
instance ExceptionMonad m => ExceptionMonad (ReaderT e m) where
gcatch (ReaderT m) c = ReaderT $ \r -> m r `gcatch` \e -> runReaderT (c e) r
gmask a = ReaderT $ \e -> gmask $ \u -> runReaderT (a $ q u) e
where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a
q u (ReaderT b) = ReaderT (u . b)
data BiosLogLevel =
BlError
| BlWarning
| BlInfo
| BlDebug
| BlVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance MonadTrans GhcT where
lift m = liftGhcT m
data BiosOptions = BiosOptions {
boGhcUserOptions :: [String]
, boLogging :: BiosLogLevel
} deriving Show
defaultOptions :: BiosOptions
defaultOptions = BiosOptions {
boGhcUserOptions = []
, boLogging = BlWarning
}
instance MonadUnliftIO Ghc where
{-# INLINE askUnliftIO #-}
askUnliftIO = Ghc $ \s ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip unGhc s))
fmBiosLog :: BiosLogLevel -> GM.GmLogLevel
fmBiosLog bl = case bl of
BlError -> GM.GmError
BlWarning -> GM.GmWarning
BlInfo -> GM.GmInfo
BlDebug -> GM.GmDebug
BlVomit -> GM.GmVomit
{-# INLINE withRunInIO #-}
withRunInIO inner =
Ghc $ \s ->
withRunInIO $ \run ->
inner (run . flip unGhc s)
-- ---------------------------------------------------------------------
instance MonadUnliftIO (GhcT IdeM) where
{-# INLINE askUnliftIO #-}
askUnliftIO = GhcT $ \s ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip unGhcT s))
-- | Apply BiosOptions to default ghc-mod Options
mkGhcModOptions :: BiosOptions -> GM.Options
mkGhcModOptions bo = GM.defaultOptions
{
GM.optGhcUserOptions = boGhcUserOptions bo
, GM.optOutput = (GM.optOutput GM.defaultOptions) { GM.ooptLogLevel = fmBiosLog (boLogging bo) }
}
{-# INLINE withRunInIO #-}
withRunInIO inner =
GhcT $ \s ->
withRunInIO $ \run ->
inner (run . flip unGhcT s)
-- ---------------------------------------------------------------------
instance MonadTransControl GhcT where
type StT GhcT a = a
{-# INLINABLE liftWith #-}
liftWith f = GhcT $ \s -> f $ \t -> unGhcT t s
{-# INLINABLE restoreT #-}
restoreT = GhcT . const
instance MonadBaseControl IO (GhcT IdeM) where
type StM (GhcT IdeM) a = ComposeSt GhcT IdeM a;
{-# INLINABLE liftBaseWith #-}
liftBaseWith = defaultLiftBaseWith
{-# INLINABLE restoreM #-}
restoreM = defaultRestoreM
instance MonadBase IO (GhcT IdeM) where
{-# INLINABLE liftBase #-}
liftBase = liftBaseDefault
instance MonadPlus (GhcT IdeM) where
{-# INLINE mzero #-}
mzero = lift mzero
{-# INLINE mplus #-}
m `mplus` n = GhcT $ \s -> unGhcT m s `mplus` unGhcT n s
instance Alternative (GhcT IdeM) where
{-# INLINE empty #-}
empty = lift empty
{-# INLINE (<|>) #-}
m <|> n = GhcT $ \s -> unGhcT m s <|> unGhcT n s
-- ghc-8.6 required
-- {-# LANGUAGE DerivingVia #-}
-- deriving via (ReaderT Session IO) instance MonadUnliftIO Ghc
-- deriving via (ReaderT Session IdeM) instance MonadUnliftIO (GhcT IdeM)
-- deriving via (ReaderT Session IdeM) instance MonadBaseControl IO (GhcT IdeM)
-- deriving via (ReaderT Session IdeM) instance MonadBase IO (GhcT IdeM)
-- deriving via (ReaderT Session IdeM) instance MonadPlus (GhcT IdeM)
-- deriving via (ReaderT Session IdeM) instance Alternative (GhcT IdeM)

15
hie-plugin-api/hie-plugin-api.cabal
View File

@ -20,6 +20,9 @@ library
exposed-modules:
Haskell.Ide.Engine.ArtifactMap
Haskell.Ide.Engine.Compat
Haskell.Ide.Engine.Cradle
Haskell.Ide.Engine.GhcCompat
Haskell.Ide.Engine.GhcUtils
Haskell.Ide.Engine.Config
Haskell.Ide.Engine.Context
Haskell.Ide.Engine.Ghc
@ -35,6 +38,9 @@ library
build-depends: base >= 4.9 && < 5
, Diff
, aeson
, bytestring-trie
, bytestring
, cryptohash-sha1
, constrained-dynamic
, containers
, data-default
@ -43,18 +49,21 @@ library
, fingertree
, free
, ghc
, ghc-mod-core >= 5.9.0.0
, hie-bios >= 0.3.2 && < 0.4.0
, ghc-project-types >= 5.9.0.0
, haskell-lsp == 0.18.*
, cabal-helper
, haskell-lsp == 0.19.*
, hslogger
, unliftio
, monad-control
, mtl
, rope-utf16-splay >= 0.3.1.0
, stm
, syb
, text
, transformers
, unordered-containers
, transformers-base
, yaml >= 0.8.11
if os(windows)
build-depends: Win32
else

31
install/src/Cabal.hs
View File

@ -91,40 +91,26 @@ installCabalWithStack = do
case mbc of
Just c -> do
checkCabal
printLine "There is already a cabal executable in $PATH with the required minimum version."
cabalVersion <- checkCabal
printLine $ "There is already a cabal executable in $PATH with the required minimum version: " ++ cabalVersion
-- install `cabal-install` if not already installed
Nothing -> execStackShake_ ["install", "cabal-install"]
checkCabal_ :: Action ()
checkCabal_ = checkCabal >> return ()
-- | check `cabal` has the required version
checkCabal :: Action ()
checkCabal :: Action String
checkCabal = do
cabalVersion <- getCabalVersion
unless (checkVersion requiredCabalVersion cabalVersion) $ do
printInStars $ cabalInstallIsOldFailMsg cabalVersion
error $ cabalInstallIsOldFailMsg cabalVersion
return cabalVersion
getCabalVersion :: Action String
getCabalVersion = trimmedStdout <$> execCabal ["--numeric-version"]
validateCabalNewInstallIsSupported :: Action ()
validateCabalNewInstallIsSupported = do
cabalVersion <- getCabalVersion
let isUnsupportedVersion =
not $ checkVersion requiredCabalVersionForWindows cabalVersion
when (isWindowsSystem && isUnsupportedVersion) $ do
printInStars cabalInstallNotSuportedFailMsg
error cabalInstallNotSuportedFailMsg
-- | Error message when a windows system tries to install HIE via `cabal v2-install`
cabalInstallNotSuportedFailMsg :: String
cabalInstallNotSuportedFailMsg =
"This system has been identified as a windows system.\n"
++ "Unfortunately, `cabal v2-install` is supported since version "++ cabalVersion ++".\n"
++ "Please upgrade your cabal executable or use one of the stack-based targets.\n\n"
++ "If this system has been falsely identified, please open an issue at:\n\thttps://github.com/haskell/haskell-ide-engine\n"
where cabalVersion = versionToString requiredCabalVersionForWindows
-- | Error message when the `cabal` binary is an older version
cabalInstallIsOldFailMsg :: String -> String
cabalInstallIsOldFailMsg cabalVersion =
@ -138,7 +124,8 @@ cabalInstallIsOldFailMsg cabalVersion =
requiredCabalVersion :: RequiredVersion
requiredCabalVersion = [2, 4, 1, 0]
requiredCabalVersion | isWindowsSystem = requiredCabalVersionForWindows
| otherwise = [2, 4, 1, 0]
requiredCabalVersionForWindows :: RequiredVersion
requiredCabalVersionForWindows = [3, 0, 0, 0]

3
install/src/HieInstall.hs
View File

@ -70,7 +70,7 @@ defaultMain = do
phony "all" shortHelpMessage
phony "help" (helpMessage versions)
phony "check-stack" checkStack
phony "check-cabal" checkCabal
phony "check-cabal" checkCabal_
phony "cabal-ghcs" $ do
let
@ -122,7 +122,6 @@ defaultMain = do
(\version -> phony ("cabal-hie-" ++ version) $ do
need ["submodules"]
need ["cabal"]
validateCabalNewInstallIsSupported
cabalBuildHie version
cabalInstallHie version
)

4
shell.nix
View File

@ -1,11 +1,11 @@
with import <nixpkgs> {};
with (import <nixpkgs> {});
stdenv.mkDerivation {
name = "haskell-ide-engine";
buildInputs = [
gmp
zlib
ncurses
haskellPackages.cabal-install
];
src = null;

8
src/Haskell/Ide/Engine/LSP/CodeActions.hs
View File

@ -32,7 +32,7 @@ handleCodeActionReq :: TrackingNumber -> J.CodeActionRequest -> R ()
handleCodeActionReq tn req = do
vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
docVersion <- fmap _version <$> liftIO (vfsFunc (J.toNormalizedUri docUri))
docVersion <- fmap virtualFileVersion <$> liftIO (vfsFunc (J.toNormalizedUri docUri))
let docId = J.VersionedTextDocumentIdentifier docUri docVersion
let getProvider p = pluginCodeActionProvider p <*> return (pluginId p)
@ -42,9 +42,9 @@ handleCodeActionReq tn req = do
providersCb providers =
let reqs = map (\f -> lift (f docId range context)) providers
in makeRequests reqs tn (req ^. J.id) (send . filter wasRequested . concat)
in makeRequests reqs "code-actions" tn (req ^. J.id) (send . filter wasRequested . concat)
makeRequest (IReq tn (req ^. J.id) providersCb getProviders)
makeRequest (IReq tn "code-actions" (req ^. J.id) providersCb getProviders)
where
params = req ^. J.params
@ -77,4 +77,4 @@ handleCodeActionReq tn req = do
body <- J.List . catMaybes <$> mapM wrapCodeAction codeActions
reactorSend $ RspCodeAction $ Core.makeResponseMessage req body
-- TODO: make context specific commands for all sorts of things, such as refactorings
-- TODO: make context specific commands for all sorts of things, such as refactorings

11
src/Haskell/Ide/Engine/LSP/Completions.hs
View File

@ -27,8 +27,6 @@ import Data.Semigroup (Semigroup(..))
import Data.Typeable
import GHC.Generics ( Generic )
import qualified GhcModCore as GM
( listVisibleModuleNames )
import HscTypes
import qualified DynFlags as GHC
@ -38,9 +36,10 @@ import Name
import TcRnTypes
import Type
import Var
import Packages (listVisibleModuleNames)
import Language.Haskell.Refact.API ( showGhc )
-- import Language.Haskell.Refact.API ( showGhc )
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Types.Capabilities
@ -59,6 +58,10 @@ import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.Context
import Language.Haskell.GHC.ExactPrint.Utils
-- ---------------------------------------------------------------------
data CompItem = CI
{ origName :: Name -- ^ Original name, such as Maybe, //, or find.
, importedFrom :: T.Text -- ^ From where this item is imported from.
@ -244,7 +247,7 @@ instance ModuleCache CachedCompletions where
importDeclerations = map unLoc limports
-- The list of all importable Modules from all packages
moduleNames = map showModName (GM.listVisibleModuleNames (getDynFlags tm))
moduleNames = map showModName (listVisibleModuleNames (getDynFlags tm))
-- The given namespaces for the imported modules (ie. full name, or alias if used)
allModNamesAsNS = map (showModName . asNamespace) importDeclerations

15
src/Haskell/Ide/Engine/LSP/Reactor.hs
View File

@ -9,6 +9,7 @@ module Haskell.Ide.Engine.LSP.Reactor
, makeRequest
, makeRequests
, updateDocumentRequest
, updateDocument
, cancelRequest
, asksLspFuncs
, getClientConfig
@ -116,6 +117,11 @@ updateDocumentRequest
:: (MonadIO m, MonadReader REnv m) => Uri -> Int -> PluginRequest R -> m ()
updateDocumentRequest = Scheduler.updateDocumentRequest
updateDocument :: (MonadIO m, MonadReader REnv m) => Uri -> Int -> m ()
updateDocument uri ver = do
re <- scheduler <$> ask
liftIO $ Scheduler.updateDocument re uri ver
-- | Marks a s requests as cencelled by its LspId
cancelRequest :: (MonadIO m, MonadReader REnv m) => J.LspId -> m ()
cancelRequest lid =
@ -124,15 +130,16 @@ cancelRequest lid =
-- | Execute multiple ide requests sequentially
makeRequests
:: [IdeDeferM (IdeResult a)] -- ^ The requests to make
-> String
-> TrackingNumber
-> J.LspId
-> ([a] -> R ()) -- ^ Callback with the request inputs and results
-> R ()
makeRequests = go []
where
go acc [] _ _ callback = callback acc
go acc (x : xs) tn reqId callback =
let reqCallback result = go (acc ++ [result]) xs tn reqId callback
in makeRequest $ IReq tn reqId reqCallback x
go acc [] _ _ _ callback = callback acc
go acc (x : xs) d tn reqId callback =
let reqCallback result = go (acc ++ [result]) xs d tn reqId callback
in makeRequest $ IReq tn d reqId reqCallback x
-- ---------------------------------------------------------------------

15
src/Haskell/Ide/Engine/Options.hs
View File

@ -9,7 +9,7 @@ data GlobalOpts = GlobalOpts
, optLsp :: Bool
, optJson :: Bool
, projectRoot :: Maybe String
, optGhcModVomit :: Bool
, optBiosVerbose :: Bool
, optCaptureFile :: Maybe FilePath
, optExamplePlugin :: Bool
} deriving (Show)
@ -38,9 +38,16 @@ globalOptsParser = GlobalOpts
<> short 'r'
<> metavar "PROJECTROOT"
<> help "Root directory of project, defaults to cwd"))
<*> switch
( long "vomit"
<> help "enable vomit logging for ghc-mod")
<*> (switch
( long "bios-verbose"
<> help "enable verbose logging for hie-bios"
)
<|>
switch
( long "vomit"
<> help "(deprecated) enable verbose logging for hie-bios"
)
)
<*> optional (strOption
( long "capture"
<> short 'c'

80
src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs
View File

@ -19,7 +19,6 @@ import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.Text as T
import GHC.Generics
import qualified GhcModCore as GM ( mkRevRedirMapFunc, withMappedFile )
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
@ -76,14 +75,18 @@ applyOneCmd = CmdSync $ \(AOP uri pos title) -> do
applyOneCmd' :: Uri -> OneHint -> IdeGhcM (IdeResult WorkspaceEdit)
applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do
revMapp <- GM.mkRevRedirMapFunc
res <- GM.withMappedFile fp $ \file' -> liftToGhc $ applyHint file' (Just oneHint) revMapp
logm $ "applyOneCmd:file=" ++ show fp
logm $ "applyOneCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyOne: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
revMapp <- reverseFileMap
let defaultResult = do
debugm "applyOne: no access to the persisted file."
return $ IdeResultOk mempty
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' (Just oneHint) revMapp
logm $ "applyOneCmd:file=" ++ show fp
logm $ "applyOneCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "applyOne: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
@ -94,13 +97,17 @@ applyAllCmd = CmdSync $ \uri -> do
applyAllCmd' :: Uri -> IdeGhcM (IdeResult WorkspaceEdit)
applyAllCmd' uri = pluginGetFile "applyAll: " uri $ \fp -> do
revMapp <- GM.mkRevRedirMapFunc
res <- GM.withMappedFile fp $ \file' -> liftToGhc $ applyHint file' Nothing revMapp
logm $ "applyAllCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyAll: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
let defaultResult = do
debugm "applyAll: no access to the persisted file."
return $ IdeResultOk mempty
revMapp <- reverseFileMap
withMappedFile fp defaultResult $ \file' -> do
res <- liftToGhc $ applyHint file' Nothing revMapp
logm $ "applyAllCmd:res=" ++ show res
case res of
Left err -> return $ IdeResultFail (IdeError PluginError
(T.pack $ "applyAll: " ++ show err) Null)
Right fs -> return (IdeResultOk fs)
-- ---------------------------------------------------------------------
@ -111,25 +118,30 @@ lintCmd = CmdSync $ \uri -> do
-- AZ:TODO: Why is this in IdeGhcM?
lintCmd' :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams)
lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do
eitherErrorResult <- GM.withMappedFile fp $ \file' ->
liftIO (try $ runExceptT $ runLintCmd file' [] :: IO (Either IOException (Either [Diagnostic] [Idea])))
case eitherErrorResult of
Left err ->
let
defaultResult = do
debugm "lintCmd: no access to the persisted file."
return
$ IdeResultFail (IdeError PluginError
(T.pack $ "lintCmd: " ++ show err) Null)
Right res -> case res of
Left diags ->
return
(IdeResultOk
(PublishDiagnosticsParams (filePathToUri fp) $ List diags)
)
Right fs ->
return
$ IdeResultOk
$ PublishDiagnosticsParams (filePathToUri fp)
$ List (map hintToDiagnostic $ stripIgnores fs)
$ IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List [])
withMappedFile fp defaultResult $ \file' -> do
eitherErrorResult <- liftIO
(try $ runExceptT $ runLintCmd file' [] :: IO
(Either IOException (Either [Diagnostic] [Idea]))
)
case eitherErrorResult of
Left err -> return $ IdeResultFail
(IdeError PluginError (T.pack $ "lintCmd: " ++ show err) Null)
Right res -> case res of
Left diags ->
return
(IdeResultOk
(PublishDiagnosticsParams (filePathToUri fp) $ List diags)
)
Right fs ->
return
$ IdeResultOk
$ PublishDiagnosticsParams (filePathToUri fp)
$ List (map hintToDiagnostic $ stripIgnores fs)
runLintCmd :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea]
runLintCmd fp args = do

9
src/Haskell/Ide/Engine/Plugin/Base.hs
View File

@ -17,6 +17,8 @@ import Development.GitRev (gitCommitCount)
import Distribution.System (buildArch)
import Distribution.Text (display)
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.Cradle (isStackCradle)
import qualified HIE.Bios.Types as BIOS
import Options.Applicative.Simple (simpleVersion)
import qualified Paths_haskell_ide_engine as Meta
@ -102,11 +104,10 @@ version =
hieGhcDisplayVersion :: String
hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc
getProjectGhcVersion :: IO String
getProjectGhcVersion = do
isStackProject <- doesFileExist "stack.yaml"
getProjectGhcVersion :: BIOS.Cradle -> IO String
getProjectGhcVersion crdl = do
isStackInstalled <- isJust <$> findExecutable "stack"
if isStackProject && isStackInstalled
if isStackCradle crdl && isStackInstalled
then do
L.infoM "hie" "Using stack GHC version"
catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do

32
src/Haskell/Ide/Engine/Plugin/Bios.hs Normal file
View File

@ -0,0 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
module Haskell.Ide.Engine.Plugin.Bios
( setTypecheckedModule
, biosDescriptor
)
where
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.Ghc
-- ---------------------------------------------------------------------
biosDescriptor :: PluginId -> PluginDescriptor
biosDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "bios"
, pluginDesc = "bios"
, pluginCommands =
[PluginCommand "check" "check a file for GHC warnings and errors" checkCmd]
, pluginCodeActionProvider = Nothing
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
checkCmd :: CommandFunc Uri (Diagnostics, AdditionalErrs)
checkCmd = CmdSync setTypecheckedModule
-- ---------------------------------------------------------------------

532
src/Haskell/Ide/Engine/Plugin/Build.hs
View File

@ -1,532 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
module Haskell.Ide.Engine.Plugin.Build where
#ifdef MIN_VERSION_Cabal
#undef CH_MIN_VERSION_Cabal
#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal
#endif
import qualified Data.Aeson as J
import Data.Maybe (fromMaybe)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import qualified Data.ByteString as B
import qualified Data.Text as T
import GHC.Generics (Generic)
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import System.Directory (doesFileExist,
getCurrentDirectory,
getDirectoryContents,
makeAbsolute)
import System.FilePath (makeRelative,
normalise,
takeExtension,
takeFileName, (</>))
import System.IO (IOMode (..), withFile)
import System.Process (readProcess)
import Distribution.Helper as CH
import Distribution.Package (pkgName, unPackageName)
import Distribution.PackageDescription
import Distribution.Simple.Configure (localBuildInfoFile)
import Distribution.Simple.Setup (defaultDistPref)
#if CH_MIN_VERSION_Cabal(2,2,0)
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#elif CH_MIN_VERSION_Cabal(2,0,0)
import Distribution.PackageDescription.Parse (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parse (readPackageDescription)
#endif
import qualified Distribution.Verbosity as Verb
import Data.Yaml
-- ---------------------------------------------------------------------
{-
buildModeArg = SParamDesc (Proxy :: Proxy "mode") (Proxy :: Proxy "Operation mode: \"stack\" or \"cabal\"") SPtText SRequired
distDirArg = SParamDesc (Proxy :: Proxy "distDir") (Proxy :: Proxy "Directory to search for setup-config file") SPtFile SOptional
toolArgs = SParamDesc (Proxy :: Proxy "cabalExe") (Proxy :: Proxy "Cabal executable") SPtText SOptional
:& SParamDesc (Proxy :: Proxy "stackExe") (Proxy :: Proxy "Stack executable") SPtText SOptional
:& RNil
pluginCommonArgs = buildModeArg :& distDirArg :& toolArgs
buildPluginDescriptor :: TaggedPluginDescriptor _
buildPluginDescriptor = PluginDescriptor
{
pdUIShortName = "Build plugin"
, pdUIOverview = "A HIE plugin for building cabal/stack packages"
, pdCommands =
buildCommand prepareHelper (Proxy :: Proxy "prepare")
"Prepares helper executable. The project must be configured first"
[] (SCtxNone :& RNil)
( pluginCommonArgs
<+> RNil) SaveNone
-- :& buildCommand isHelperPrepared (Proxy :: Proxy "isPrepared")
-- "Checks whether cabal-helper is prepared to work with this project. The project must be configured first"
-- [] (SCtxNone :& RNil)
-- ( pluginCommonArgs
-- <+> RNil) SaveNone
:& buildCommand isConfigured (Proxy :: Proxy "isConfigured")
"Checks if project is configured"
[] (SCtxNone :& RNil)
( buildModeArg
:& distDirArg
:& RNil) SaveNone
:& buildCommand configure (Proxy :: Proxy "configure")
"Configures the project. For stack project with multiple local packages - build it"
[] (SCtxNone :& RNil)
( pluginCommonArgs
<+> RNil) SaveNone
:& buildCommand listTargets (Proxy :: Proxy "listTargets")
"Given a directory with stack/cabal project lists all its targets"
[] (SCtxNone :& RNil)
( pluginCommonArgs
<+> RNil) SaveNone
:& buildCommand listFlags (Proxy :: Proxy "listFlags")
"Lists all flags that can be set when configuring a package"
[] (SCtxNone :& RNil)
( buildModeArg
:& RNil) SaveNone
:& buildCommand buildDirectory (Proxy :: Proxy "buildDirectory")
"Builds all targets that correspond to the specified directory"
[] (SCtxNone :& RNil)
( pluginCommonArgs
<+> (SParamDesc (Proxy :: Proxy "directory") (Proxy :: Proxy "Directory to build targets from") SPtFile SOptional :& RNil)
<+> RNil) SaveNone
:& buildCommand buildTarget (Proxy :: Proxy "buildTarget")
"Builds specified cabal or stack component"
[] (SCtxNone :& RNil)
( pluginCommonArgs
<+> (SParamDesc (Proxy :: Proxy "target") (Proxy :: Proxy "Component to build") SPtText SOptional :& RNil)
<+> (SParamDesc (Proxy :: Proxy "package") (Proxy :: Proxy "Package to search the component in. Only applicable for Stack mode") SPtText SOptional :& RNil)
<+> (SParamDesc (Proxy :: Proxy "type") (Proxy :: Proxy "Type of the component. Only applicable for Stack mode") SPtText SOptional :& RNil)
<+> RNil) SaveNone
:& RNil
, pdExposedServices = []
, pdUsedServices = []
}
-}
buildPluginDescriptor :: PluginId -> PluginDescriptor
buildPluginDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "Build plugin"
, pluginDesc = "A HIE plugin for building cabal/stack packages"
, pluginCommands =
[ PluginCommand "prepare"
"Prepares helper executable. The project must be configured first"
prepareHelper
-- , PluginCommand "isPrepared"
-- ("Checks whether cabal-helper is prepared to work with this project. "
-- <> "The project must be configured first")
-- isHelperPrepared
, PluginCommand "isConfigured"
"Checks if project is configured"
isConfigured
, PluginCommand "configure"
("Configures the project. "
<> "For stack project with multiple local packages - build it")
configure
, PluginCommand "listTargets"
"Given a directory with stack/cabal project lists all its targets"
listTargets
, PluginCommand "listFlags"
"Lists all flags that can be set when configuring a package"
listFlags
, PluginCommand "buildDirectory"
"Builds all targets that correspond to the specified directory"
buildDirectory
, PluginCommand "buildTarget"
"Builds specified cabal or stack component"
buildTarget
]
, pluginCodeActionProvider = Nothing
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
data OperationMode = StackMode | CabalMode
readMode :: T.Text -> Maybe OperationMode
readMode "stack" = Just StackMode
readMode "cabal" = Just CabalMode
readMode _ = Nothing
-- | Used internally by commands, all fields always populated, possibly with
-- default values
data CommonArgs = CommonArgs {
caMode :: OperationMode
,caDistDir :: String
,caCabal :: String
,caStack :: String
}
-- | Used to interface with the transport, where the mode is required but rest
-- are optional
data CommonParams = CommonParams {
cpMode :: T.Text
,cpDistDir :: Maybe String
,cpCabal :: Maybe String
,cpStack :: Maybe String
,cpFile :: Uri
} deriving Generic
instance FromJSON CommonParams where
parseJSON = J.genericParseJSON $ customOptions 2
instance ToJSON CommonParams where
toJSON = J.genericToJSON $ customOptions 2
incorrectParameter :: String -> [String] -> a -> b
incorrectParameter = undefined
withCommonArgs :: MonadIO m => CommonParams -> ReaderT CommonArgs m a -> m a
withCommonArgs (CommonParams mode0 mDistDir mCabalExe mStackExe _fileUri) a =
case readMode mode0 of
Nothing -> return $ incorrectParameter "mode" ["stack","cabal"] mode0
Just mode -> do
let cabalExe = fromMaybe "cabal" mCabalExe
stackExe = fromMaybe "stack" mStackExe
distDir' <- maybe (liftIO $ getDistDir mode stackExe) return
mDistDir -- >>= uriToFilePath -- fileUri
runReaderT a $ CommonArgs {
caMode = mode,
caDistDir = distDir',
caCabal = cabalExe,
caStack = stackExe
}
{-
withCommonArgs req a = do
case getParams (IdText "mode" :& RNil) req of
Left err -> return err
Right (ParamText mode0 :& RNil) -> do
case readMode mode0 of
Nothing -> return $ incorrectParameter "mode" ["stack","cabal"] mode0
Just mode -> do
let cabalExe = maybe "cabal" id $
Map.lookup "cabalExe" (ideParams req) >>= (\(ParamTextP v) -> return $ T.unpack v)
stackExe = maybe "stack" id $
Map.lookup "stackExe" (ideParams req) >>= (\(ParamTextP v) -> return $ T.unpack v)
distDir' <- maybe (liftIO $ getDistDir mode stackExe) return $
Map.lookup "distDir" (ideParams req) >>=
uriToFilePath . (\(ParamFileP v) -> v)
runReaderT a $ CommonArgs {
caMode = mode,
caDistDir = distDir',
caCabal = cabalExe,
caStack = stackExe
}
-}
-----------------------------------------------
-- isHelperPrepared :: CommandFunc Bool
-- isHelperPrepared = CmdSync $ \ctx req -> withCommonArgs ctx req $ do
-- distDir' <- asks caDistDir
-- ret <- liftIO $ isPrepared (defaultQueryEnv "." distDir')
-- return $ IdeResultOk ret
-----------------------------------------------
prepareHelper :: CommandFunc CommonParams ()
prepareHelper = CmdSync $ \req -> withCommonArgs req $ do
ca <- ask
liftIO $ case caMode ca of
StackMode -> do
slp <- getStackLocalPackages "stack.yaml"
mapM_ (prepareHelper' (caDistDir ca) (caCabal ca)) slp
CabalMode -> prepareHelper' (caDistDir ca) (caCabal ca) "."
return $ IdeResultOk ()
prepareHelper' :: MonadIO m => FilePath -> FilePath -> FilePath -> m ()
prepareHelper' distDir' cabalExe dir =
prepare $ (mkQueryEnv dir distDir') {qePrograms = defaultPrograms {cabalProgram = cabalExe}}
-----------------------------------------------
isConfigured :: CommandFunc CommonParams Bool
isConfigured = CmdSync $ \req -> withCommonArgs req $ do
distDir' <- asks caDistDir
ret <- liftIO $ doesFileExist $ localBuildInfoFile distDir'
return $ IdeResultOk ret
-----------------------------------------------
configure :: CommandFunc CommonParams ()
configure = CmdSync $ \req -> withCommonArgs req $ do
ca <- ask
_ <- liftIO $ case caMode ca of
StackMode -> configureStack (caStack ca)
CabalMode -> configureCabal (caCabal ca)
return $ IdeResultOk ()
configureStack :: FilePath -> IO String
configureStack stackExe = do
slp <- getStackLocalPackages "stack.yaml"
-- stack can configure only single local package
case slp of
[_singlePackage] -> readProcess stackExe ["build", "--only-configure"] ""
_manyPackages -> readProcess stackExe ["build"] ""
configureCabal :: FilePath -> IO String
configureCabal cabalExe = readProcess cabalExe ["new-configure"] ""
-----------------------------------------------
newtype ListFlagsParams = LF { lfMode :: T.Text } deriving Generic
instance FromJSON ListFlagsParams where
parseJSON = J.genericParseJSON $ customOptions 2
instance ToJSON ListFlagsParams where
toJSON = J.genericToJSON $ customOptions 2
listFlags :: CommandFunc ListFlagsParams Object
listFlags = CmdSync $ \(LF mode) -> do
cwd <- liftIO getCurrentDirectory
flags0 <- liftIO $ case mode of
"stack" -> listFlagsStack cwd
"cabal" -> fmap (:[]) (listFlagsCabal cwd)
_oops -> return []
let flags' = flip map flags0 $ \(n,f) ->
object ["packageName" .= n, "flags" .= map flagToJSON f]
(Object ret) = object ["res" .= toJSON flags']
return $ IdeResultOk ret
listFlagsStack :: FilePath -> IO [(String,[Flag])]
listFlagsStack d = do
stackPackageDirs <- getStackLocalPackages (d </> "stack.yaml")
mapM (listFlagsCabal . (d </>)) stackPackageDirs
listFlagsCabal :: FilePath -> IO (String,[Flag])
listFlagsCabal d = do
[cabalFile] <- filter isCabalFile <$> getDirectoryContents d
#if MIN_VERSION_Cabal(2,0,0)
gpd <- readGenericPackageDescription Verb.silent (d </> cabalFile)
#else
gpd <- readPackageDescription Verb.silent (d </> cabalFile)
#endif
let name = unPackageName $ pkgName $ package $ packageDescription gpd
flags' = genPackageFlags gpd
return (name, flags')
flagToJSON :: Flag -> Value
flagToJSON f = object
-- Cabal 2.0 changelog
-- * Backwards incompatible change to 'FlagName' (#4062):
-- 'FlagName' is now opaque; conversion to/from 'String' now works
-- via 'unFlagName' and 'mkFlagName' functions.
[ "name" .= unFlagName (flagName f)
, "description" .= flagDescription f
, "default" .= flagDefault f]
#if MIN_VERSION_Cabal(2,0,0)
#else
unFlagName :: FlagName -> String
unFlagName (FlagName s) = s
#endif
-----------------------------------------------
data BuildParams = BP {
-- common params. horrible
bpMode :: T.Text
,bpDistDir :: Maybe String
,bpCabal :: Maybe String
,bpStack :: Maybe String
,bpFile :: Uri
-- specific params
,bpDirectory :: Maybe Uri
} deriving Generic
instance FromJSON BuildParams where
parseJSON = J.genericParseJSON $ customOptions 2
instance ToJSON BuildParams where
toJSON = J.genericToJSON $ customOptions 2
buildDirectory :: CommandFunc BuildParams ()
buildDirectory = CmdSync $ \(BP m dd c s f mbDir) -> withCommonArgs (CommonParams m dd c s f) $ do
ca <- ask
liftIO $ case caMode ca of
CabalMode -> do
-- for cabal specifying directory have no sense
_ <- readProcess (caCabal ca) ["new-build"] ""
return $ IdeResultOk ()
StackMode ->
case mbDir of
Nothing -> do
_ <- readProcess (caStack ca) ["build"] ""
return $ IdeResultOk ()
Just dir0 -> pluginGetFile "buildDirectory" dir0 $ \dir -> do
cwd <- getCurrentDirectory
let relDir = makeRelative cwd $ normalise dir
_ <- readProcess (caStack ca) ["build", relDir] ""
return $ IdeResultOk ()
-----------------------------------------------
data BuildTargetParams = BT {
-- common params. horrible
btMode :: T.Text
,btDistDir :: Maybe String
,btCabal :: Maybe String
,btStack :: Maybe String
,btFile :: Uri
-- specific params
,btTarget :: Maybe T.Text
,btPackage :: Maybe T.Text
,btType :: T.Text
} deriving Generic
instance FromJSON BuildTargetParams where
parseJSON = J.genericParseJSON $ customOptions 2
instance ToJSON BuildTargetParams where
toJSON = J.genericToJSON $ customOptions 2
buildTarget :: CommandFunc BuildTargetParams ()
buildTarget = CmdSync $ \(BT m dd c s f component package' compType) -> withCommonArgs (CommonParams m dd c s f) $ do
ca <- ask
liftIO $ case caMode ca of
CabalMode -> do
_ <- readProcess (caCabal ca) ["new-build", T.unpack $ fromMaybe "" component] ""
return $ IdeResultOk ()
StackMode ->
case (package', component) of
(Just p, Nothing) -> do
_ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType] ""
return $ IdeResultOk ()
(Just p, Just c') -> do
_ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType `T.append` (':' `T.cons` c')] ""
return $ IdeResultOk ()
(Nothing, Just c') -> do
_ <- readProcess (caStack ca) ["build", T.unpack $ ':' `T.cons` c'] ""
return $ IdeResultOk ()
_ -> do
_ <- readProcess (caStack ca) ["build"] ""
return $ IdeResultOk ()
-----------------------------------------------
data Package = Package {
tPackageName :: String
,tDirectory :: String
,tTargets :: [ChComponentName]
}
listTargets :: CommandFunc CommonParams [Value]
listTargets = CmdSync $ \req -> withCommonArgs req $ do
ca <- ask
targets <- liftIO $ case caMode ca of
CabalMode -> (:[]) <$> listCabalTargets (caDistDir ca) "."
StackMode -> listStackTargets (caDistDir ca)
let ret = flip map targets $ \t -> object
["name" .= tPackageName t,
"directory" .= tDirectory t,
"targets" .= map compToJSON (tTargets t)]
return $ IdeResultOk ret
listStackTargets :: FilePath -> IO [Package]
listStackTargets distDir' = do
stackPackageDirs <- getStackLocalPackages "stack.yaml"
mapM (listCabalTargets distDir') stackPackageDirs
listCabalTargets :: MonadIO m => FilePath -> FilePath -> m Package
listCabalTargets distDir' dir =
runQuery (mkQueryEnv dir distDir') $ do
pkgName' <- fst <$> packageId
cc <- components $ (,) CH.<$> entrypoints
let comps = map (fixupLibraryEntrypoint pkgName' .snd) cc
absDir <- liftIO $ makeAbsolute dir
return $ Package pkgName' absDir comps
where
-- # if MIN_VERSION_Cabal(2,0,0)
#if MIN_VERSION_Cabal(1,24,0)
fixupLibraryEntrypoint _n ChLibName = ChLibName
#else
fixupLibraryEntrypoint n (ChLibName "") = ChLibName n
#endif
fixupLibraryEntrypoint _ e = e
-- Example of new way to use cabal helper 'entrypoints' is a ComponentQuery,
-- components applies it to all components in the project, the semigroupoids
-- apply batches the result per component, and returns the component as the last
-- item.
getComponents :: QueryEnv -> IO [(ChEntrypoint,ChComponentName)]
getComponents env = runQuery env $ components $ (,) CH.<$> entrypoints
-----------------------------------------------
newtype StackYaml = StackYaml [StackPackage]
data StackPackage = LocalOrHTTPPackage { stackPackageName :: String }
| Repository
instance FromJSON StackYaml where
parseJSON (Object o) = StackYaml <$>
o .: "packages"
parseJSON _ = mempty
instance FromJSON StackPackage where
parseJSON (Object _) = pure Repository
parseJSON (String s) = pure $ LocalOrHTTPPackage (T.unpack s)
parseJSON _ = mempty
isLocal :: StackPackage -> Bool
isLocal (LocalOrHTTPPackage _) = True
isLocal _ = False
getStackLocalPackages :: FilePath -> IO [String]
getStackLocalPackages stackYamlFile = withBinaryFileContents stackYamlFile $ \contents -> do
let (Just (StackYaml stackYaml)) = decodeThrow contents
stackLocalPackages = map stackPackageName $ filter isLocal stackYaml
return stackLocalPackages
compToJSON :: ChComponentName -> Value
compToJSON ChSetupHsName = object ["type" .= ("setupHs" :: T.Text)]
#if MIN_VERSION_Cabal(1,24,0)
compToJSON ChLibName = object ["type" .= ("library" :: T.Text)]
compToJSON (ChSubLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n]
compToJSON (ChFLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n]
#else
compToJSON (ChLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n]
#endif
compToJSON (ChExeName n) = object ["type" .= ("executable" :: T.Text), "name" .= n]
compToJSON (ChTestName n) = object ["type" .= ("test" :: T.Text), "name" .= n]
compToJSON (ChBenchName n) = object ["type" .= ("benchmark" :: T.Text), "name" .= n]
-----------------------------------------------
getDistDir :: OperationMode -> FilePath -> IO FilePath
getDistDir CabalMode _ = do
cwd <- getCurrentDirectory
return $ cwd </> defaultDistPref
getDistDir StackMode stackExe = do
cwd <- getCurrentDirectory
dist <- init <$> readProcess stackExe ["path", "--dist-dir"] ""
return $ cwd </> dist
isCabalFile :: FilePath -> Bool
isCabalFile f = takeExtension' f == ".cabal"
takeExtension' :: FilePath -> String
takeExtension' p =
if takeFileName p == takeExtension p
then "" -- just ".cabal" is not a valid cabal file
else takeExtension p
withBinaryFileContents :: FilePath -> (B.ByteString -> IO c) -> IO c
withBinaryFileContents name act = withFile name ReadMode $ B.hGetContents >=> act
customOptions :: Int -> J.Options
customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n}

110
src/Haskell/Ide/Engine/Plugin/GhcMod.hs → src/Haskell/Ide/Engine/Plugin/Generic.hs
View File

@ -5,24 +5,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Haskell.Ide.Engine.Plugin.GhcMod
(
ghcmodDescriptor
-- * For tests
, Bindings(..)
, FunctionSig(..)
, TypeDef(..)
, TypeParams(..)
, TypedHoles(..) -- only to keep the GHC 8.4 and below unused field warning happy
, ValidSubstitutions(..)
, extractHoleSubstitutions
, extractMissingSignature
, extractRenamableTerms
, extractUnusedTerm
, newTypeCmd
, symbolProvider
) where
-- Generic actions which require a typechecked module
module Haskell.Ide.Engine.Plugin.Generic where
import Control.Lens hiding (cons, children)
import Data.Aeson
@ -34,42 +18,34 @@ import Data.Monoid ((<>))
import qualified Data.Text as T
import Name
import GHC.Generics
import qualified GhcModCore as GM ( pretty, GhcPs )
import Haskell.Ide.Engine.Ghc
import Haskell.Ide.Engine.MonadTypes hiding (defaultOptions)
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.Support.FromHaRe
import qualified Haskell.Ide.Engine.GhcCompat as C ( GhcPs )
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
import Haskell.Ide.Engine.ArtifactMap
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Language.Haskell.Refact.API (hsNamessRdr)
-- import Language.Haskell.Refact.API (hsNamessRdr)
import HIE.Bios.Ghc.Doc
import GHC
import HscTypes
import DataCon
import TcRnTypes
import Outputable (mkUserStyle, Depth(..))
import Outputable hiding ((<>))
import PprTyThing
-- ---------------------------------------------------------------------
ghcmodDescriptor :: PluginId -> PluginDescriptor
ghcmodDescriptor plId = PluginDescriptor
genericDescriptor :: PluginId -> PluginDescriptor
genericDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "ghc-mod"
, pluginDesc = "ghc-mod is a backend program to enrich Haskell programming "
<> "in editors. It strives to offer most of the features one has come to expect "
<> "from modern IDEs in any editor."
, pluginCommands =
[
-- This one is used in the dispatcher tests, and is a wrapper around what we are already using anyway
PluginCommand "check" "check a file for GHC warnings and errors" checkCmd
-- PluginCommand "info" "Look up an identifier in the context of FILE (like ghci's `:info')" infoCmd
, PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd
-- This one is registered in the vscode plugin, for some reason
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" Hie.splitCaseCmd
]
, pluginName = "generic"
, pluginDesc = "generic actions"
, pluginCommands = [PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd]
, pluginCodeActionProvider = Just codeActionProvider
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Just hoverProvider
@ -79,16 +55,6 @@ ghcmodDescriptor plId = PluginDescriptor
-- ---------------------------------------------------------------------
checkCmd :: CommandFunc Uri (Diagnostics, AdditionalErrs)
checkCmd = CmdSync setTypecheckedModule
-- ---------------------------------------------------------------------
customOptions :: Options
customOptions = defaultOptions { fieldLabelModifier = camelTo2 '_' . drop 2}
-- ---------------------------------------------------------------------
data TypeParams =
TP { tpIncludeConstraints :: Bool
, tpFile :: Uri
@ -107,7 +73,8 @@ typeCmd = CmdSync $ \(TP _bool uri pos) ->
newTypeCmd :: Position -> Uri -> IdeM (IdeResult [(Range, T.Text)])
newTypeCmd newPos uri =
pluginGetFile "newTypeCmd: " uri $ \fp ->
ifCachedModule fp (IdeResultOk []) $ \tm info ->
ifCachedModule fp (IdeResultOk []) $ \tm info -> do
debugm $ "newTypeCmd: " <> (show (newPos, uri))
return $ IdeResultOk $ pureTypeCmd newPos tm info
pureTypeCmd :: Position -> GHC.TypecheckedModule -> CachedInfo -> [(Range,T.Text)]
@ -126,9 +93,13 @@ pureTypeCmd newPos tm info =
f (range', t) =
case oldRangeToNew info range' of
(Just range) -> [(range , T.pack $ GM.pretty dflag st t)]
(Just range) -> [(range , T.pack $ prettyTy st t)]
_ -> []
prettyTy stl
= showOneLine dflag stl . pprTypeForUser
-- TODO: MP: Why is this defined here?
cmp :: Range -> Range -> Ordering
cmp a b
| a `isSubRangeOf` b = LT
@ -139,6 +110,21 @@ isSubRangeOf :: Range -> Range -> Bool
isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea
-- ---------------------------------------------------------------------
--
-- ---------------------------------------------------------------------
customOptions :: Options
customOptions = defaultOptions { fieldLabelModifier = camelTo2 '_' . drop 2}
data InfoParams =
IP { ipFile :: Uri
, ipExpr :: T.Text
} deriving (Eq,Show,Generic)
instance FromJSON InfoParams where
parseJSON = genericParseJSON customOptions
instance ToJSON InfoParams where
toJSON = genericToJSON customOptions
newtype TypeDef = TypeDef T.Text deriving (Eq, Show)
@ -206,7 +192,7 @@ codeActionProvider' supportsDocChanges _ docId _ context =
codeAction = LSP.CodeAction title (Just kind) (Just diags) (Just we) Nothing
getRenamables :: LSP.Diagnostic -> [(LSP.Diagnostic, T.Text)]
getRenamables diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) = map (diag,) $ extractRenamableTerms msg
getRenamables diag@(LSP.Diagnostic _ _ _ (Just "bios") msg _) = map (diag,) $ extractRenamableTerms msg
getRenamables _ = []
mkRedundantImportActions :: LSP.Diagnostic -> T.Text -> [LSP.CodeAction]
@ -232,7 +218,7 @@ codeActionProvider' supportsDocChanges _ docId _ context =
tEdit = LSP.TextEdit (diag ^. LSP.range) ("import " <> modName <> "()")
getRedundantImports :: LSP.Diagnostic -> Maybe (LSP.Diagnostic, T.Text)
getRedundantImports diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractRedundantImport msg
getRedundantImports diag@(LSP.Diagnostic _ _ _ (Just "bios") msg _) = (diag,) <$> extractRedundantImport msg
getRedundantImports _ = Nothing
mkTypedHoleActions :: TypedHoles -> [LSP.CodeAction]
@ -254,14 +240,14 @@ codeActionProvider' supportsDocChanges _ docId _ context =
getTypedHoles :: LSP.Diagnostic -> Maybe TypedHoles
getTypedHoles diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) =
getTypedHoles diag@(LSP.Diagnostic _ _ _ (Just "bios") msg _) =
case extractHoleSubstitutions msg of
Nothing -> Nothing
Just (want, subs, bindings) -> Just $ TypedHoles diag want subs bindings
getTypedHoles _ = Nothing
getMissingSignatures :: LSP.Diagnostic -> Maybe (LSP.Diagnostic, T.Text)
getMissingSignatures diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) =
getMissingSignatures diag@(LSP.Diagnostic _ _ _ (Just "bios") msg _) =
case extractMissingSignature msg of
Nothing -> Nothing
Just signature -> Just (diag, signature)
@ -279,7 +265,7 @@ codeActionProvider' supportsDocChanges _ docId _ context =
codeAction = LSP.CodeAction title (Just kind) (Just diags) (Just edit) Nothing
getUnusedTerms :: LSP.Diagnostic -> Maybe (LSP.Diagnostic, T.Text)
getUnusedTerms diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) =
getUnusedTerms diag@(LSP.Diagnostic _ _ _ (Just "bios") msg _) =
case extractUnusedTerm msg of
Nothing -> Nothing
Just signature -> Just (diag, signature)
@ -442,7 +428,7 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $
imps = concatMap goImport imports
decls = concatMap go $ hsmodDecls hsMod
go :: LHsDecl GM.GhcPs -> [Decl]
go :: LHsDecl C.GhcPs -> [Decl]
#if __GLASGOW_HASKELL__ >= 806
go (L l (TyClD _ d)) = goTyClD (L l d)
#else
@ -484,7 +470,7 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $
-- -----------------------------
goValD :: LHsBind GM.GhcPs -> [Decl]
goValD :: LHsBind C.GhcPs -> [Decl]
goValD (L l (FunBind { fun_id = ln, fun_matches = MG { mg_alts = llms } })) =
pure (Decl LSP.SkFunction ln wheres l)
where
@ -531,7 +517,7 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $
-- -----------------------------
processSig :: LSig GM.GhcPs -> [Decl]
processSig :: LSig C.GhcPs -> [Decl]
#if __GLASGOW_HASKELL__ >= 806
processSig (L l (ClassOpSig _ False names _)) =
#else
@ -540,7 +526,7 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $
map (\n -> Decl LSP.SkMethod n [] l) names
processSig _ = []
processCon :: LConDecl GM.GhcPs -> [Decl]
processCon :: LConDecl C.GhcPs -> [Decl]
processCon (L l ConDeclGADT { con_names = names }) =
map (\n -> Decl LSP.SkConstructor n [] l) names
#if __GLASGOW_HASKELL__ >= 806
@ -560,7 +546,7 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri $
processCon (L _ (XConDecl _)) = error "processCon"
#endif
goImport :: LImportDecl GM.GhcPs -> [Decl]
goImport :: LImportDecl C.GhcPs -> [Decl]
goImport (L l ImportDecl { ideclName = lmn, ideclAs = as, ideclHiding = meis }) = pure im
where
im = Import imKind lmn xs l

323
src/Haskell/Ide/Engine/Plugin/HaRe.hs
View File

@ -1,323 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Haskell.Ide.Engine.Plugin.HaRe where
import Control.Lens.Operators
import Control.Monad.State
import Control.Monad.Trans.Control
import Data.Aeson
import qualified Data.Aeson.Types as J
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Foldable
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Exception
import GHC.Generics (Generic)
import qualified GhcModCore as GM (GhcModError(..),withMappedFile,GHandler(..),gcatches)
import Haskell.Ide.Engine.ArtifactMap
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
import Language.Haskell.GHC.ExactPrint.Print
import qualified Language.Haskell.LSP.Core as Core
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Types.Lens as J
import Language.Haskell.Refact.API hiding (logm)
import Language.Haskell.Refact.HaRe
import Language.Haskell.Refact.Utils.Monad hiding (logm)
-- ---------------------------------------------------------------------
hareDescriptor :: PluginId -> PluginDescriptor
hareDescriptor plId = PluginDescriptor
{ pluginId = plId
, pluginName = "HaRe"
, pluginDesc = "A Haskell 2010 refactoring tool. HaRe supports the full "
<> "Haskell 2010 standard, through making use of the GHC API. HaRe attempts to "
<> "operate in a safe way, by first writing new files with proposed changes, and "
<> "only swapping these with the originals when the change is accepted. "
, pluginCommands =
[ PluginCommand "demote" "Move a definition one level down"
demoteCmd
, PluginCommand "dupdef" "Duplicate a definition"
dupdefCmd
, PluginCommand "iftocase" "Converts an if statement to a case statement"
iftocaseCmd
, PluginCommand "liftonelevel" "Move a definition one level up from where it is now"
liftonelevelCmd
, PluginCommand "lifttotoplevel" "Move a definition to the top level from where it is now"
lifttotoplevelCmd
, PluginCommand "rename" "rename a variable or type"
renameCmd
, PluginCommand "deletedef" "Delete a definition"
deleteDefCmd
, PluginCommand "genapplicative" "Generalise a monadic function to use applicative"
genApplicativeCommand
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)"
Hie.splitCaseCmd
]
, pluginCodeActionProvider = Just codeActionProvider
, pluginDiagnosticProvider = Nothing
, pluginHoverProvider = Nothing
, pluginSymbolProvider = Nothing
, pluginFormattingProvider = Nothing
}
-- ---------------------------------------------------------------------
data HarePointWithText =
HPT { hptFile :: Uri
, hptPos :: Position
, hptText :: T.Text
} deriving (Eq,Generic,Show)
instance FromJSON HarePointWithText where
parseJSON = genericParseJSON $ Hie.customOptions 3
instance ToJSON HarePointWithText where
toJSON = genericToJSON $ Hie.customOptions 3
data HareRange =
HR { hrFile :: Uri
, hrStartPos :: Position
, hrEndPos :: Position
} deriving (Eq,Generic,Show)
instance FromJSON HareRange where
parseJSON = genericParseJSON $ Hie.customOptions 2
instance ToJSON HareRange where
toJSON = genericToJSON $ Hie.customOptions 2
-- ---------------------------------------------------------------------
demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
demoteCmd = CmdSync $ \(Hie.HP uri pos) ->
demoteCmd' uri pos
demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
demoteCmd' uri pos =
pluginGetFile "demote: " uri $ \file ->
runHareCommand "demote" (compDemote file (unPos pos))
-- compDemote :: FilePath -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
dupdefCmd :: CommandFunc HarePointWithText WorkspaceEdit
dupdefCmd = CmdSync $ \(HPT uri pos name) ->
dupdefCmd' uri pos name
dupdefCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit)
dupdefCmd' uri pos name =
pluginGetFile "dupdef: " uri $ \file ->
runHareCommand "dupdef" (compDuplicateDef file (T.unpack name) (unPos pos))
-- compDuplicateDef :: FilePath -> String -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
iftocaseCmd :: CommandFunc HareRange WorkspaceEdit
iftocaseCmd = CmdSync $ \(HR uri startPos endPos) ->
iftocaseCmd' uri (Range startPos endPos)
iftocaseCmd' :: Uri -> Range -> IdeGhcM (IdeResult WorkspaceEdit)
iftocaseCmd' uri (Range startPos endPos) =
pluginGetFile "iftocase: " uri $ \file ->
runHareCommand "iftocase" (compIfToCase file (unPos startPos) (unPos endPos))
-- compIfToCase :: FilePath -> SimpPos -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
liftonelevelCmd = CmdSync $ \(Hie.HP uri pos) ->
liftonelevelCmd' uri pos
liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
liftonelevelCmd' uri pos =
pluginGetFile "liftonelevelCmd: " uri $ \file ->
runHareCommand "liftonelevel" (compLiftOneLevel file (unPos pos))
-- compLiftOneLevel :: FilePath -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
lifttotoplevelCmd = CmdSync $ \(Hie.HP uri pos) ->
lifttotoplevelCmd' uri pos
lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
lifttotoplevelCmd' uri pos =
pluginGetFile "lifttotoplevelCmd: " uri $ \file ->
runHareCommand "lifttotoplevel" (compLiftToTopLevel file (unPos pos))
-- compLiftToTopLevel :: FilePath -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
renameCmd :: CommandFunc HarePointWithText WorkspaceEdit
renameCmd = CmdSync $ \(HPT uri pos name) ->
renameCmd' uri pos name
renameCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit)
renameCmd' uri pos name =
pluginGetFile "rename: " uri $ \file ->
runHareCommand "rename" (compRename file (T.unpack name) (unPos pos))
-- compRename :: FilePath -> String -> SimpPos -> IO [FilePath]
-- ---------------------------------------------------------------------
deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
deleteDefCmd = CmdSync $ \(Hie.HP uri pos) ->
deleteDefCmd' uri pos
deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
deleteDefCmd' uri pos =
pluginGetFile "deletedef: " uri $ \file ->
runHareCommand "deltetedef" (compDeleteDef file (unPos pos))
-- compDeleteDef ::FilePath -> SimpPos -> RefactGhc [ApplyRefacResult]
-- ---------------------------------------------------------------------
genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit
genApplicativeCommand = CmdSync $ \(Hie.HP uri pos) ->
genApplicativeCommand' uri pos
genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
genApplicativeCommand' uri pos =
pluginGetFile "genapplicative: " uri $ \file ->
runHareCommand "genapplicative" (compGenApplicative file (unPos pos))
-- ---------------------------------------------------------------------
getRefactorResult :: [ApplyRefacResult] -> [(FilePath,T.Text)]
getRefactorResult = map getNewFile . filter fileModified
where fileModified ((_,m),_) = m == RefacModified
getNewFile ((file,_),(ann, parsed)) = (file, T.pack $ exactPrint parsed ann)
makeRefactorResult :: [(FilePath,T.Text)] -> IdeGhcM WorkspaceEdit
makeRefactorResult changedFiles = do
let
diffOne :: (FilePath, T.Text) -> IdeGhcM WorkspaceEdit
diffOne (fp, newText) = do
origText <- GM.withMappedFile fp $ liftIO . T.readFile
-- TODO: remove this logging once we are sure we have a working solution
logm $ "makeRefactorResult:groupedDiff = " ++ show (getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText))
logm $ "makeRefactorResult:diffops = " ++ show (diffToLineRanges $ getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText))
liftToGhc $ diffText (filePathToUri fp, origText) newText IncludeDeletions
diffs <- mapM diffOne changedFiles
return $ Core.reverseSortEdit $ fold diffs
-- ---------------------------------------------------------------------
runHareCommand :: String -> RefactGhc [ApplyRefacResult]
-> IdeGhcM (IdeResult WorkspaceEdit)
runHareCommand name cmd = do
eitherRes <- runHareCommand' cmd
case eitherRes of
Left err ->
pure (IdeResultFail
(IdeError PluginError
(T.pack $ name <> ": \"" <> err <> "\"")
Null))
Right res -> do
let changes = getRefactorResult res
refactRes <- makeRefactorResult changes
pure (IdeResultOk refactRes)
-- ---------------------------------------------------------------------
-- newtype RefactGhc a = RefactGhc
-- { unRefactGhc :: StateT RefactState HIE.IdeGhcM a
-- }
runHareCommand' :: forall a. RefactGhc a
-> IdeGhcM (Either String a)
runHareCommand' cmd =
do let initialState =
-- TODO: Make this a command line flag
RefSt {rsSettings = defaultSettings
-- RefSt {rsSettings = logSettings
,rsUniqState = 1
,rsSrcSpanCol = 1
,rsFlags = RefFlags False
,rsStorage = StorageNone
,rsCurrentTarget = Nothing
,rsModule = Nothing}
let
cmd' :: StateT RefactState IdeGhcM a
cmd' = unRefactGhc cmd
embeddedCmd =
evalStateT cmd' initialState
handlers
:: Applicative m
=> [GM.GHandler m (Either String a)]
handlers =
[GM.GHandler (\(ErrorCall e) -> pure (Left e))
,GM.GHandler (\(err :: GM.GhcModError) -> pure (Left (show err)))]
fmap Right embeddedCmd `GM.gcatches` handlers
-- ---------------------------------------------------------------------
-- | This is like hoist from the mmorph package, but build on
-- `MonadTransControl` since we don’t have an `MFunctor` instance.
hoist
:: (MonadTransControl t,Monad (t m'),Monad m',Monad m)
=> (forall b. m b -> m' b) -> t m a -> t m' a
hoist f a =
liftWith (\run ->
let b = run a
c = f b
in pure c) >>=
restoreT
-- ---------------------------------------------------------------------
codeActionProvider :: CodeActionProvider
codeActionProvider pId docId (J.Range pos _) _ =
pluginGetFile "HaRe codeActionProvider: " (docId ^. J.uri) $ \file ->
ifCachedInfo file (IdeResultOk mempty) $ \info ->
case getArtifactsAtPos pos (defMap info) of
[h] -> do
let name = Hie.showName $ snd h
debugm $ show name
IdeResultOk <$> sequence [
mkAction "liftonelevel"
J.CodeActionRefactorExtract $ "Lift " <> name <> " one level"
, mkAction "lifttotoplevel"
J.CodeActionRefactorExtract $ "Lift " <> name <> " to top level"
, mkAction "demote"
J.CodeActionRefactorInline $ "Demote " <> name <> " one level"
, mkAction "deletedef"
J.CodeActionRefactor $ "Delete definition of " <> name
, mkHptAction "dupdef"
J.CodeActionRefactor "Duplicate definition of " name
]
_ -> case getArtifactsAtPos pos (locMap info) of
[h] -> do
let name = Hie.showName $ snd h
IdeResultOk <$> sequence [
mkAction "casesplit"
J.CodeActionRefactorRewrite $ "Case split on " <> name
]
_ -> return $ IdeResultOk []
where
mkAction aId kind title = do
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
cmd <- mkLspCommand pId aId title (Just args)
return $ J.CodeAction title (Just kind) mempty Nothing (Just cmd)
mkHptAction aId kind title name = do
let args = [J.toJSON $ HPT (docId ^. J.uri) pos (name <> "'")]
cmd <- mkLspCommand pId aId title (Just args)
return $ J.CodeAction (title <> name) (Just kind) mempty Nothing (Just cmd)

9
src/Haskell/Ide/Engine/Plugin/Haddock.hs
View File

@ -14,7 +14,6 @@ import Data.Function
import Data.Maybe
import Data.List
import GHC
import qualified GhcModCore as GM ( LightGhc(..), runLightGhc )
import GhcMonad
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
@ -81,13 +80,15 @@ nameCacheFromGhcMonad = ( read_from_session , write_to_session )
ref <- withSession (return . hsc_NC)
liftIO $ writeIORef ref nc'
runInLightGhc :: GM.LightGhc a -> IdeM a
runInLightGhc :: Ghc a -> IdeM a
runInLightGhc a = do
hscEnvRef <- ghcSession <$> readMTS
mhscEnv <- liftIO $ traverse readIORef hscEnvRef
case mhscEnv of
liftIO $ case mhscEnv of
Nothing -> error "Ghc Session not initialized"
Just env -> GM.runLightGhc env a
Just env -> do
session <- Session <$> newIORef env
unGhc a session
nameCacheFromIdeM :: NameCacheAccessor IdeM
nameCacheFromIdeM = ( read_from_session , write_to_session )

12
src/Haskell/Ide/Engine/Plugin/HsImport.hs
View File

@ -14,10 +14,10 @@ import Data.Monoid ( (<>) )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified GHC.Generics as Generics
import qualified GhcModCore as GM ( mkRevRedirMapFunc, withMappedFile )
import qualified HsImport
import Haskell.Ide.Engine.Config
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.MonadFunctions (debugm)
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Types.Lens as J
@ -128,9 +128,11 @@ importModule
importModule uri impStyle modName =
pluginGetFile "hsimport cmd: " uri $ \origInput -> do
shouldFormat <- formatOnImportOn <$> getConfig
fileMap <- GM.mkRevRedirMapFunc
GM.withMappedFile origInput $ \input -> do
fileMap <- reverseFileMap
let defaultResult = do
debugm "hsimport: no access to the persisted file."
return $ IdeResultOk mempty
withMappedFile origInput defaultResult $ \input -> do
tmpDir <- liftIO getTemporaryDirectory
(output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput"
liftIO $ hClose outputH
@ -461,7 +463,7 @@ codeActionProvider plId docId _ context = do
-- | For a Diagnostic, get an associated function name.
-- If Ghc-Mod can not find any candidates, Nothing is returned.
getImportables :: J.Diagnostic -> Maybe ImportDiagnostic
getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
getImportables diag@(J.Diagnostic _ _ _ (Just "bios") msg _) =
uncurry (ImportDiagnostic diag) <$> extractImportableTerm msg
getImportables _ = Nothing

2
src/Haskell/Ide/Engine/Plugin/Liquid.hs
View File

@ -7,7 +7,7 @@ module Haskell.Ide.Engine.Plugin.Liquid where
import Control.Concurrent.Async.Lifted
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Trans.Class
import Control.Exception (bracket)
import Data.Aeson
import qualified Data.ByteString.Lazy as BS

5
src/Haskell/Ide/Engine/Plugin/Package.hs
View File

@ -45,7 +45,6 @@ import System.FilePath
#endif
import Control.Monad.IO.Class
import System.Directory
import qualified GhcModCore as GM ( mkRevRedirMapFunc )
import Distribution.Types.GenericPackageDescription
import Distribution.Types.CondTree
import qualified Distribution.PackageDescription.PrettyPrint as PP
@ -98,7 +97,7 @@ addCmd = CmdSync addCmd'
addCmd' :: AddParams -> IdeGhcM (IdeResult J.WorkspaceEdit)
addCmd' (AddParams rootDir modulePath pkg) = do
packageType <- liftIO $ findPackageType rootDir
fileMap <- GM.mkRevRedirMapFunc
fileMap <- reverseFileMap
case packageType of
CabalPackage relFp -> do
@ -333,7 +332,7 @@ codeActionProvider plId docId _ context = do
_ -> return Nothing
getAddablePackages :: J.Diagnostic -> Maybe (J.Diagnostic, Package)
getAddablePackages diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractModuleName msg
getAddablePackages diag@(J.Diagnostic _ _ _ (Just "bios") msg _) = (diag,) <$> extractModuleName msg
getAddablePackages _ = Nothing
-- | Extract a module name from an error message.

2
src/Haskell/Ide/Engine/Plugin/Pragmas.hs
View File

@ -66,7 +66,7 @@ codeActionProvider plId docId _ (J.CodeActionContext (J.List diags) _monly) = do
return $ IdeResultOk cmds
where
-- Filter diagnostics that are from ghcmod
ghcDiags = filter (\d -> d ^. J.source == Just "ghcmod") diags
ghcDiags = filter (\d -> d ^. J.source == Just "bios") diags
-- Get all potential Pragmas for all diagnostics.
pragmas = concatMap (\d -> findPragma (d ^. J.message)) ghcDiags
mkCommand pragmaName = do

103
src/Haskell/Ide/Engine/Scheduler.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Haskell.Ide.Engine.Scheduler
( Scheduler
, DocUpdate
@ -16,10 +18,12 @@ module Haskell.Ide.Engine.Scheduler
, cancelRequest
, makeRequest
, updateDocumentRequest
, updateDocument
)
where
import Control.Concurrent.Async ( race_ )
import Control.Concurrent.Async
import GHC.Conc
import qualified Control.Concurrent.STM as STM
import Control.Monad.IO.Class ( liftIO
, MonadIO
@ -32,8 +36,10 @@ import Control.Monad
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as T
import HIE.Bios.Types
import qualified Language.Haskell.LSP.Core as Core
import qualified Language.Haskell.LSP.Types as J
import GhcMonad
import Haskell.Ide.Engine.GhcModuleCache
import Haskell.Ide.Engine.Config
@ -43,6 +49,8 @@ import Haskell.Ide.Engine.Types
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Debug.Trace
-- | A Scheduler is a coordinator between the two main processes the ide engine uses
-- for responding to users requests. It accepts all of the requests and dispatches
@ -59,9 +67,8 @@ data Scheduler m = Scheduler
{ plugins :: IdePlugins
-- ^ The list of plugins that will be used for responding to requests
, biosOptions :: BiosOptions
-- ^ Options for the bios session. Since we only keep a single bios session
-- at a time, this cannot be changed a runtime.
, biosOpts :: CradleOpts
-- ^ Options for the hie-bios cradle finding
, requestsToCancel :: STM.TVar (Set.Set J.LspId)
-- ^ The request IDs that were canceled by the client. This causes requests to
@ -98,10 +105,10 @@ class HasScheduler a m where
newScheduler
:: IdePlugins
-- ^ The list of plugins that will be used for responding to requests
-> BiosOptions
-- ^ Options for the bios session. Since we only keep a single bios session
-> CradleOpts
-- ^ Options for the bios session. Since we only keep a single bios option record.
-> IO (Scheduler m)
newScheduler plugins biosOpts = do
newScheduler plugins cradleOpts = do
cancelTVar <- STM.atomically $ STM.newTVar Set.empty
wipTVar <- STM.atomically $ STM.newTVar Set.empty
versionTVar <- STM.atomically $ STM.newTVar Map.empty
@ -109,7 +116,7 @@ newScheduler plugins biosOpts = do
ghcChan <- Channel.newChan
return $ Scheduler
{ plugins = plugins
, biosOptions = biosOpts
, biosOpts = cradleOpts
, requestsToCancel = cancelTVar
, requestsInProgress = wipTVar
, documentVersions = versionTVar
@ -118,7 +125,7 @@ newScheduler plugins biosOpts = do
}
-- | A handler for any errors that the dispatcher may encounter.
type ErrorHandler = J.LspId -> J.ErrorCode -> T.Text -> IO ()
type ErrorHandler = Maybe J.LspId -> J.ErrorCode -> T.Text -> IO ()
-- | A handler to run the requests' callback in your monad of choosing.
type CallbackHandler m = forall a. RequestCallback m a -> a -> IO ()
@ -151,13 +158,18 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
stateVar <- STM.newTVarIO initialState
let runGhcDisp = runIdeGhcM biosOptions plugins mlf stateVar $
let runGhcDisp = runIdeGhcM plugins mlf stateVar $
ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut
runIdeDisp = runIdeM plugins mlf stateVar $
ideDispatcher dEnv errorHandler callbackHandler ideChanOut
runGhcDisp `race_` runIdeDisp
withAsync runGhcDisp $ \a ->
withAsync runIdeDisp $ \b -> do
flip labelThread "ghc" $ asyncThreadId a
flip labelThread "ide" $ asyncThreadId b
waitEither_ a b
-- | Sends a request to the scheduler so that it can be dispatched to the handler
@ -171,20 +183,13 @@ sendRequest
:: forall m
. Scheduler m
-- ^ The scheduler to send the request to.
-> Maybe DocUpdate
-- ^ If not Nothing, the version for the given document is updated before dispatching.
-> PluginRequest m
-> PluginRequest m
-- ^ The request to dispatch.
-> IO ()
sendRequest Scheduler {..} docUpdate req = do
sendRequest Scheduler {..} req = do
let (ghcChanIn, _) = ghcChan
(ideChanIn, _) = ideChan
case docUpdate of
Nothing -> pure ()
Just (uri, ver) ->
STM.atomically $ STM.modifyTVar' documentVersions (Map.insert uri ver)
case req of
Right ghcRequest@GhcRequest { pinLspReqId = Nothing } ->
Channel.writeChan ghcChanIn ghcRequest
@ -215,7 +220,7 @@ makeRequest
-> m ()
makeRequest req = do
env <- ask
liftIO $ sendRequest (getScheduler env) Nothing req
liftIO $ sendRequest (getScheduler env) req
-- | Updates the version of a document and then sends the request to be processed
-- asynchronously.
@ -227,7 +232,20 @@ updateDocumentRequest
-> m ()
updateDocumentRequest uri ver req = do
env <- ask
liftIO $ sendRequest (getScheduler env) (Just (uri, ver)) req
let sched = (getScheduler env)
liftIO $ do
updateDocument sched uri ver
sendRequest sched req
-- | Updates the version of a document and then sends the request to be processed
-- asynchronously.
updateDocument
:: Scheduler a
-> Uri
-> Int
-> IO ()
updateDocument sched uri ver =
STM.atomically $ STM.modifyTVar' (documentVersions sched) (Map.insert uri ver)
-------------------------------------------------------------------------------
-- Dispatcher
@ -259,7 +277,8 @@ ideDispatcher
ideDispatcher env errorHandler callbackHandler pin =
forever $ do
debugm "ideDispatcher: top of loop"
(IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin
(IdeRequest tn d lid callback action) <- liftIO $ Channel.readChan pin
liftIO $ traceEventIO $ "START " ++ show tn ++ "ide:" ++ d
debugm
$ "ideDispatcher: got request "
++ show tn
@ -273,7 +292,9 @@ ideDispatcher env errorHandler callbackHandler pin =
case result of
IdeResultOk x -> callbackHandler callback x
IdeResultFail (IdeError _ msg _) ->
errorHandler lid J.InternalError msg
errorHandler (Just lid) J.InternalError msg
liftIO $ traceEventIO $ "STOP " ++ show tn ++ "ide:" ++ d
where
queueDeferred (Defer fp cacheCb) = lift $ modifyMTState $ \s ->
let oldQueue = requestQueue s
@ -296,31 +317,35 @@ ghcDispatcher
-> Channel.OutChan (GhcRequest m)
-> IdeGhcM void
ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler pin
= forever $ do
= do
iniDynFlags <- getSessionDynFlags
forever $ do
debugm "ghcDispatcher: top of loop"
(GhcRequest tn context mver mid callback action) <- liftIO
GhcRequest tn d context mver mid callback def action <- liftIO
$ Channel.readChan pin
debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid
liftIO $ traceEventIO $ "START " ++ show tn ++ "ghc:" ++ d
let
runner = case context of
Nothing -> runActionWithContext Nothing
runner :: a -> IdeGhcM a -> IdeGhcM (IdeResult a)
runner a act = case context of
Nothing -> runActionWithContext iniDynFlags Nothing a act
Just uri -> case uriToFilePath uri of
Just fp -> runActionWithContext (Just fp)
Nothing -> \act -> do
Just fp -> runActionWithContext iniDynFlags (Just fp) a act
Nothing -> do
debugm
"ghcDispatcher:Got malformed uri, running action with default context"
runActionWithContext Nothing act
runActionWithContext iniDynFlags Nothing a act
let
runWithCallback = do
result <- runner action
liftIO $ case result of
result <- runner (pure def) action
liftIO $ case join result of
IdeResultOk x -> callbackHandler callback x
IdeResultFail err@(IdeError _ msg _) -> case mid of
Just lid -> errorHandler lid J.InternalError msg
Nothing ->
debugm $ "ghcDispatcher:Got error for a request: " ++ show err
IdeResultFail err@(IdeError _ msg _) -> do
logm $ "ghcDispatcher:Got error for a request: " ++ show err ++ " with mid: " ++ show mid
errorHandler mid J.InternalError msg
let
runIfVersionMatch = case mver of
@ -343,11 +368,11 @@ ghcDispatcher env@DispatcherEnv { docVersionTVar } errorHandler callbackHandler
Just lid -> unlessCancelled env lid errorHandler $ do
liftIO $ completedReq env lid
runIfVersionMatch
liftIO $ traceEventIO $ "STOP " ++ show tn ++ "ghc:" ++ d
-- | Runs the passed monad only if the request identified by the passed LspId
-- has not already been cancelled.
unlessCancelled
-- :: GM.MonadIO m => DispatcherEnv -> J.LspId -> ErrorHandler -> m () -> m ()
:: MonadIO m => DispatcherEnv -> J.LspId -> ErrorHandler -> m () -> m ()
unlessCancelled env lid errorHandler callback = do
cancelled <- liftIO $ STM.atomically isCancelled
@ -356,7 +381,7 @@ unlessCancelled env lid errorHandler callback = do
-- remove from cancelled and wip list
STM.atomically $ STM.modifyTVar' (cancelReqsTVar env) (Set.delete lid)
completedReq env lid
errorHandler lid J.RequestCancelled ""
errorHandler (Just lid) J.RequestCancelled ""
else callback
where isCancelled = Set.member lid <$> STM.readTVar (cancelReqsTVar env)

221
src/Haskell/Ide/Engine/Support/FromHaRe.hs Normal file
View File

@ -0,0 +1,221 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Haskell.Ide.Engine.Support.FromHaRe
(
initRdrNameMap
, NameMap
, hsNamessRdr
) where
-- Code migrated from HaRe, until HaRe comes back
-- import Control.Monad.State
import Data.List
import Data.Maybe
import qualified GHC as GHC
-- import qualified GhcMonad as GHC
-- import qualified Haskell.Ide.Engine.PluginApi as HIE (makeRevRedirMapFunc)
import qualified Module as GHC
import qualified Name as GHC
import qualified Unique as GHC
-- import qualified HscTypes as GHC (md_exports)
-- import qualified TcRnTypes as GHC (tcg_rdr_env)
#if __GLASGOW_HASKELL__ > 710
import qualified Var
#endif
import qualified Data.Generics as SYB
-- import Language.Haskell.GHC.ExactPrint
-- import Language.Haskell.GHC.ExactPrint.Annotate
-- import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types
-- import Language.Haskell.Refact.Utils.Monad
-- import Language.Haskell.Refact.Utils.TypeSyn
-- import Language.Haskell.Refact.Utils.Types
import qualified Data.Map as Map
-- import Outputable
-- ---------------------------------------------------------------------
type NameMap = Map.Map GHC.SrcSpan GHC.Name
-- ---------------------------------------------------------------------
-- |We need the ParsedSource because it more closely reflects the actual source
-- code, but must be able to work with the renamed representation of the names
-- involved. This function constructs a map from every Located RdrName in the
-- ParsedSource to its corresponding name in the RenamedSource. It also deals
-- with the wrinkle that we need to Location of the RdrName to make sure we have
-- the right Name, but not all RdrNames have a Location.
-- This function is called before the RefactGhc monad is active.
initRdrNameMap :: GHC.TypecheckedModule -> NameMap
initRdrNameMap tm = r
where
parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module tm
renamed = GHC.tm_renamed_source tm
#if __GLASGOW_HASKELL__ > 710
typechecked = GHC.tm_typechecked_source tm
#endif
checkRdr :: GHC.Located GHC.RdrName -> Maybe [(GHC.SrcSpan,GHC.RdrName)]
checkRdr (GHC.L l n@(GHC.Unqual _)) = Just [(l,n)]
checkRdr (GHC.L l n@(GHC.Qual _ _)) = Just [(l,n)]
checkRdr (GHC.L _ _)= Nothing
checkName :: GHC.Located GHC.Name -> Maybe [GHC.Located GHC.Name]
checkName ln = Just [ln]
rdrNames = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkRdr ) parsed
#if __GLASGOW_HASKELL__ >= 806
names1 = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
names2 = names1 ++ SYB.everything (++) ([] `SYB.mkQ` fieldOcc
`SYB.extQ` hsRecFieldN) renamed
names = names2 ++ SYB.everything (++) ([] `SYB.mkQ` hsRecFieldT) typechecked
fieldOcc :: GHC.FieldOcc GhcRn -> [GHC.Located GHC.Name]
fieldOcc (GHC.FieldOcc n (GHC.L l _)) = [(GHC.L l n)]
fieldOcc (GHC.XFieldOcc _) = []
hsRecFieldN :: GHC.LHsExpr GhcRn -> [GHC.Located GHC.Name]
hsRecFieldN (GHC.L _ (GHC.HsRecFld _ (GHC.Unambiguous n (GHC.L l _) ) )) = [GHC.L l n]
hsRecFieldN _ = []
hsRecFieldT :: GHC.LHsExpr GhcTc -> [GHC.Located GHC.Name]
hsRecFieldT (GHC.L _ (GHC.HsRecFld _ (GHC.Ambiguous n (GHC.L l _)) )) = [GHC.L l (Var.varName n)]
hsRecFieldT _ = []
#elif __GLASGOW_HASKELL__ > 710
names1 = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
names2 = names1 ++ SYB.everything (++) ([] `SYB.mkQ` fieldOcc
`SYB.extQ` hsRecFieldN) renamed
names = names2 ++ SYB.everything (++) ([] `SYB.mkQ` hsRecFieldT) typechecked
fieldOcc :: GHC.FieldOcc GhcRn -> [GHC.Located GHC.Name]
fieldOcc (GHC.FieldOcc (GHC.L l _) n) = [(GHC.L l n)]
hsRecFieldN :: GHC.LHsExpr GhcRn -> [GHC.Located GHC.Name]
hsRecFieldN (GHC.L _ (GHC.HsRecFld (GHC.Unambiguous (GHC.L l _) n) )) = [GHC.L l n]
hsRecFieldN _ = []
hsRecFieldT :: GHC.LHsExpr GhcTc -> [GHC.Located GHC.Name]
hsRecFieldT (GHC.L _ (GHC.HsRecFld (GHC.Ambiguous (GHC.L l _) n) )) = [GHC.L l (Var.varName n)]
hsRecFieldT _ = []
#else
names = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed
#endif
#if __GLASGOW_HASKELL__ >= 806
namesIe = names
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)))
-- This is a workaround for https://ghc.haskell.org/trac/ghc/ticket/14189
-- namesIeParsedL = SYB.everything (++) ([] `SYB.mkQ` ieThingWith) (GHC.hsmodExports $ GHC.unLoc parsed)
namesIeParsed = Map.fromList $ SYB.everything (++) ([] `SYB.mkQ` ieThingWith) (GHC.hsmodExports $ GHC.unLoc parsed)
ieThingWith :: GHC.IE GhcPs -> [(GHC.SrcSpan, [GHC.SrcSpan])]
ieThingWith (GHC.IEThingWith l _ sub_rdrs _) = [(GHC.getLoc l,map GHC.getLoc sub_rdrs)]
ieThingWith _ = []
renamedExports = case renamed of
Nothing -> Nothing
Just (_,_,es,_) -> es
namesIeRenamed = SYB.everything (++) ([] `SYB.mkQ` ieThingWithNames) renamedExports
ieThingWithNames :: GHC.IE GhcRn -> [GHC.Located GHC.Name]
ieThingWithNames (GHC.IEThingWith l _ sub_rdrs _) = (GHC.ieLWrappedName l:nameSubs)
where
rdrSubLocs = gfromJust "ieThingWithNames" $ Map.lookup (GHC.getLoc l) namesIeParsed
nameSubs = map (\(loc,GHC.L _ lwn) -> GHC.L loc (GHC.ieWrappedName lwn)) $ zip rdrSubLocs sub_rdrs
ieThingWithNames _ = []
namesIe = case SYB.everything mappend (nameSybQuery checkName) namesIeRenamed of
Nothing -> names
Just ns -> names ++ ns
#else
namesIe = names
#endif
nameMap = Map.fromList $ map (\(GHC.L l n) -> (l,n)) namesIe
-- If the name does not exist (e.g. a TH Splice that has been expanded, make a new one)
-- No attempt is made to make sure that equivalent ones have equivalent names.
lookupName l n i = case Map.lookup l nameMap of
Just v -> v
Nothing -> case n of
GHC.Unqual u -> mkNewGhcNamePure 'h' i Nothing (GHC.occNameString u)
#if __GLASGOW_HASKELL__ <= 710
GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToPackageKey "") q)) (GHC.occNameString u)
#else
GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToUnitId "") q)) (GHC.occNameString u)
#endif
_ -> error "initRdrNameMap:should not happen"
r = Map.fromList $ map (\((l,n),i) -> (l,lookupName l n i)) $ zip rdrNames [1..]
-- ---------------------------------------------------------------------
nameSybQuery :: (SYB.Typeable a, SYB.Typeable t)
=> (GHC.Located a -> Maybe r) -> t -> Maybe r
nameSybQuery checker = q
where
q = Nothing `SYB.mkQ` worker
#if __GLASGOW_HASKELL__ <= 710
`SYB.extQ` workerBind
`SYB.extQ` workerExpr
`SYB.extQ` workerHsTyVarBndr
`SYB.extQ` workerLHsType
#endif
worker (pnt :: (GHC.Located a))
= checker pnt
#if __GLASGOW_HASKELL__ <= 710
workerBind (GHC.L l (GHC.VarPat name))
= checker (GHC.L l name)
workerBind _ = Nothing
workerExpr ((GHC.L l (GHC.HsVar name)))
= checker (GHC.L l name)
workerExpr _ = Nothing
-- workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a))
-- = checker (GHC.L ln name)
-- workerLIE _ = Nothing
workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name)))
= checker (GHC.L l name)
workerHsTyVarBndr _ = Nothing
workerLHsType ((GHC.L l (GHC.HsTyVar name)))
= checker (GHC.L l name)
workerLHsType _ = Nothing
#endif
-- ---------------------------------------------------------------------
mkNewGhcNamePure :: Char -> Int -> Maybe GHC.Module -> String -> GHC.Name
mkNewGhcNamePure c i maybeMod name =
let un = GHC.mkUnique c i -- H for HaRe :)
n = case maybeMod of
Nothing -> GHC.mkInternalName un (GHC.mkVarOcc name) GHC.noSrcSpan
Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) GHC.noSrcSpan
in n
-- ---------------------------------------------------------------------
-- |Get all the names in the given syntax element
hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName]
hsNamessRdr t = nub $ fromMaybe [] r
where
r = (SYB.everything mappend (inName) t)
checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName]
checker x = Just [x]
inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName]
inName = nameSybQuery checker
-- ---------------------------------------------------------------------

28
src/Haskell/Ide/Engine/Support/HieExtras.hs
View File

@ -20,48 +20,40 @@ module Haskell.Ide.Engine.Support.HieExtras
, VFS.PosPrefixInfo(..)
, HarePoint(..)
, customOptions
, runGhcModCommand
, splitCaseCmd'
, splitCaseCmd
-- , splitCaseCmd'
-- , splitCaseCmd
, getFormattingPlugin
) where
import Data.Semigroup (Semigroup(..))
import ConLike
import Control.Lens.Operators ( (&) )
import Control.Lens.Setter ((%~))
import Control.Lens.Traversal (traverseOf)
import Control.Monad.Reader
import Control.Monad.Except
import Control.Exception (SomeException, catch)
import Data.Aeson
import qualified Data.Aeson.Types as J
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Typeable
import DataCon
import qualified DynFlags as GHC
import Exception
import FastString
import Finder
import GHC hiding (getContext)
import GHC.Generics (Generic)
import qualified GhcMod as GM (splits',SplitResult(..))
import qualified GhcModCore as GM (GhcModError(..), withMappedFile )
import Haskell.Ide.Engine.ArtifactMap
import Haskell.Ide.Engine.Config
import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.Support.FromHaRe
import HscTypes
import qualified Language.Haskell.LSP.Types as J
import qualified Language.Haskell.LSP.Types.Lens as J
import qualified Language.Haskell.LSP.VFS as VFS
import Language.Haskell.Refact.Utils.MonadFunctions
-- import Language.Haskell.Refact.Utils.MonadFunctions
import Name
import NameCache
import Outputable (Outputable)
@ -336,8 +328,8 @@ srcSpanToFileLocation invoker rfm srcSpan = do
gotoModule :: (FilePath -> FilePath) -> ModuleName -> IdeDeferM (IdeResult [Location])
gotoModule rfm mn = do
hscEnvRef <- ghcSession <$> readMTS
mHscEnv <- liftIO $ traverse readIORef hscEnvRef
case mHscEnv of
mhscEnv <- liftIO $ traverse readIORef hscEnvRef
case mhscEnv of
Just env -> do
fr <- liftIO $ do
-- Flush cache or else we get temporary files
@ -370,6 +362,7 @@ instance ToJSON HarePoint where
-- ---------------------------------------------------------------------
{-
runGhcModCommand :: IdeGhcM a
-> IdeGhcM (IdeResult a)
runGhcModCommand cmd =
@ -378,9 +371,11 @@ runGhcModCommand cmd =
return $
IdeResultFail $
IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
-}
-- ---------------------------------------------------------------------
{-
splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit
splitCaseCmd = CmdSync $ \(HP uri pos) -> splitCaseCmd' uri pos
@ -436,6 +431,7 @@ splitCaseCmd' uri newPos =
textLines = T.lines txt
dropLines = drop l textLines
dropCharacters = T.drop c (T.unlines dropLines)
-}
getFormattingPlugin :: Config -> IdePlugins -> Maybe (PluginDescriptor, FormattingProvider)
getFormattingPlugin config plugins = do
@ -443,3 +439,5 @@ getFormattingPlugin config plugins = do
fmtPlugin <- Map.lookup providerName (ipMap plugins)
fmtProvider <- pluginFormattingProvider fmtPlugin
return (fmtPlugin, fmtProvider)
-- ---------------------------------------------------------------------

6
src/Haskell/Ide/Engine/Transport/JsonStdio.hs
View File

@ -95,11 +95,11 @@ run scheduler = flip E.catches handlers $ do
case mreq of
Nothing -> return()
Just req -> do
let preq = GReq 0 (context req) Nothing (Just $ J.IdInt rid) (liftIO . callback)
let preq = GReq 0 "" (context req) Nothing (Just $ J.IdInt rid) (liftIO . callback) (toDynJSON (Nothing :: Maybe ()))
$ runPluginCommand (plugin req) (command req) (arg req)
rid = reqId req
callback = sendResponse rid . dynToJSON
Scheduler.sendRequest scheduler Nothing preq
Scheduler.sendRequest scheduler preq
getNextReq :: IO (Maybe ReactorInput)
getNextReq = do
@ -124,4 +124,4 @@ getNextReq = do
else do
rest <- readReqByteString
let cur = B.charUtf8 char
return $ Just $ maybe cur (cur <>) rest
return $ Just $ maybe cur (cur <>) rest

178
src/Haskell/Ide/Engine/Transport/LspStdio.hs
View File

@ -23,9 +23,9 @@ import Control.Lens ( (^.) )
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import qualified Data.Aeson as A
import Control.Monad.STM
import Data.Aeson ( (.=) )
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy as BL
import Data.Coerce (coerce)
import Data.Default
@ -37,7 +37,8 @@ import qualified Data.Set as S
import qualified Data.SortedList as SL
import qualified Data.Text as T
import Data.Text.Encoding
import qualified GhcModCore as GM ( loadMappedFileSource, getMMappedFiles )
import qualified Data.Yaml as Yaml
import Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
import Haskell.Ide.Engine.Config
import qualified Haskell.Ide.Engine.Ghc as HIE
import Haskell.Ide.Engine.LSP.CodeActions
@ -47,12 +48,13 @@ import Haskell.Ide.Engine.MonadFunctions
import Haskell.Ide.Engine.MonadTypes
import qualified Haskell.Ide.Engine.Plugin.ApplyRefact as ApplyRefact
import Haskell.Ide.Engine.Plugin.Base
import qualified Haskell.Ide.Engine.Plugin.HaRe as HaRe
-- import qualified Haskell.Ide.Engine.Plugin.HaRe as HaRe
import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle
import Haskell.Ide.Engine.PluginUtils
import qualified Haskell.Ide.Engine.Scheduler as Scheduler
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
import Haskell.Ide.Engine.Types
import qualified Haskell.Ide.Engine.Plugin.Bios as BIOS
import qualified Language.Haskell.LSP.Control as CTRL
import qualified Language.Haskell.LSP.Core as Core
import Language.Haskell.LSP.Diagnostics
@ -62,9 +64,11 @@ import Language.Haskell.LSP.Types.Capabilities as C
import qualified Language.Haskell.LSP.Types.Lens as J
import qualified Language.Haskell.LSP.Utility as U
import qualified Language.Haskell.LSP.VFS as VFS
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))
import System.Exit
import qualified System.Log.Logger as L
import qualified Data.Rope.UTF16 as Rope
import GHC.Conc
-- ---------------------------------------------------------------------
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
@ -124,8 +128,11 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
reactorFunc = react $ reactor rin diagIn
let errorHandler :: Scheduler.ErrorHandler
errorHandler lid code e =
errorHandler (Just lid) code e =
Core.sendErrorResponseS (Core.sendFunc lf) (J.responseId lid) code e
errorHandler Nothing _code e =
Core.sendErrorShowS (Core.sendFunc lf) e
callbackHandler :: Scheduler.CallbackHandler R
callbackHandler f x = react $ f x
@ -148,9 +155,9 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
-- haskell lsp sets the current directory to the project root in the InitializeRequest
-- We launch the dispatcher after that so that the default cradle is
-- recognized properly by ghc-mod
_ <- forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf)
_ <- forkIO reactorFunc
_ <- forkIO $ diagnosticsQueue tr
flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf))
flip labelThread "reactor" =<< (forkIO reactorFunc)
flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
return Nothing
diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
@ -210,26 +217,6 @@ getPrefixAtPos uri pos = do
-- ---------------------------------------------------------------------
mapFileFromVfs :: (MonadIO m, MonadReader REnv m)
=> TrackingNumber
-> J.VersionedTextDocumentIdentifier -> m ()
mapFileFromVfs tn vtdi = do
let uri = vtdi ^. J.uri
ver = fromMaybe 0 (vtdi ^. J.version)
vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
mvf <- liftIO $ vfsFunc (J.toNormalizedUri uri)
case (mvf, uriToFilePath uri) of
(Just (VFS.VirtualFile _ rope), Just fp) -> do
let text' = Rope.toString rope
-- text = "{-# LINE 1 \"" ++ fp ++ "\"#-}\n" <> text'
let req = GReq tn (Just uri) Nothing Nothing (const $ return ())
$ IdeResultOk <$> do
GM.loadMappedFileSource fp text'
fileMap <- GM.getMMappedFiles
debugm $ "file mapping state is: " ++ show fileMap
updateDocumentRequest uri ver req
(_, _) -> return ()
-- TODO: generalise this and move it to GhcMod.ModuleLoader
updatePositionMap :: Uri -> [J.TextDocumentContentChangeEvent] -> IdeGhcM (IdeResult ())
updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file ->
@ -364,7 +351,7 @@ reactor inp diagIn = do
liftIO $ U.logs $ "reactor:got RspFromClient:" ++ show resp
case merr of
Nothing -> return ()
Just _ -> sendErrorLog $ "Got error response:" <> decodeUtf8 (BL.toStrict $ J.encode resp)
Just _ -> sendErrorLog $ "Got error response:" <> decodeUtf8 (BL.toStrict $ A.encode resp)
-- -------------------------------
@ -395,7 +382,7 @@ reactor inp diagIn = do
-- TODO: Register all commands?
hareId <- mkLspCmdId "hare" "demote"
let
options = J.object ["documentSelector" .= J.object [ "language" .= J.String "haskell"]]
options = A.object ["documentSelector" .= A.object [ "language" .= A.String "haskell"]]
registrationsList =
[ J.Registration hareId J.WorkspaceExecuteCommand (Just options)
]
@ -410,28 +397,41 @@ reactor inp diagIn = do
reactorSend $ NotLogMessage $
fmServerLogMessageNotification J.MtLog $ "Using hie version: " <> T.pack version
lspRootDir <- asksLspFuncs Core.rootPath
currentDir <- liftIO getCurrentDirectory
-- Check for mismatching GHC versions
projGhcVersion <- liftIO getProjectGhcVersion
when (projGhcVersion /= hieGhcVersion) $ do
let msg = T.pack $ "Mismatching GHC versions: Project is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
++ "\nYou may want to use hie-wrapper. Check the README for more information"
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
-- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
cradleRes <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
-- Check cabal is installed
hasCabal <- liftIO checkCabalInstall
unless hasCabal $ do
let msg = T.pack "cabal-install is not installed. Check the README for more information"
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
case cradleRes of
Just cradle -> do
projGhcVersion <- liftIO $ getProjectGhcVersion cradle
when (projGhcVersion /= hieGhcVersion) $ do
let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
" is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
++ "\nYou may want to use hie-wrapper. Check the README for more information"
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
-- Check cabal is installed
-- TODO: only do this check if its a cabal cradle
hasCabal <- liftIO checkCabalInstall
unless hasCabal $ do
let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information"
reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
lf <- ask
let hreq = GReq tn Nothing Nothing Nothing callback $ IdeResultOk <$> Hoogle.initializeHoogleDb
callback Nothing = flip runReaderT lf $
Nothing -> return ()
renv <- ask
let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb
callback Nothing = flip runReaderT renv $
reactorSend $ NotShowMessage $
fmServerShowMessageNotification J.MtWarning "No hoogle db found. Check the README for instructions to generate one"
callback (Just db) = flip runReaderT lf $ do
callback (Just db) = flip runReaderT renv $ do
reactorSend $ NotLogMessage $
fmServerLogMessageNotification J.MtLog $ "Using hoogle db at: " <> T.pack db
makeRequest hreq
@ -443,10 +443,10 @@ reactor inp diagIn = do
let
td = notification ^. J.params . J.textDocument
uri = td ^. J.uri
ver = Just $ td ^. J.version
mapFileFromVfs tn $ J.VersionedTextDocumentIdentifier uri ver
ver = td ^. J.version
updateDocument uri ver
-- We want to execute diagnostics for a newly opened file as soon as possible
requestDiagnostics $ DiagnosticsRequest DiagnosticOnOpen tn uri ver
requestDiagnostics $ DiagnosticsRequest DiagnosticOnOpen tn uri (Just ver)
-- -------------------------------
@ -466,11 +466,9 @@ reactor inp diagIn = do
let
td = notification ^. J.params . J.textDocument
uri = td ^. J.uri
-- ver = Just $ td ^. J.version
ver = Nothing
mapFileFromVfs tn $ J.VersionedTextDocumentIdentifier uri ver
updateDocument uri 0
-- don't debounce/queue diagnostics when saving
requestDiagnostics (DiagnosticsRequest DiagnosticOnSave tn uri ver)
requestDiagnostics (DiagnosticsRequest DiagnosticOnSave tn uri Nothing)
-- -------------------------------
@ -482,13 +480,12 @@ reactor inp diagIn = do
uri = vtdi ^. J.uri
ver = vtdi ^. J.version
J.List changes = params ^. J.contentChanges
mapFileFromVfs tn vtdi
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $
updateDocumentRequest uri (fromMaybe 0 ver) $ GReq tn "update-position" (Just uri) Nothing Nothing (const $ return ()) () $
-- Important - Call this before requestDiagnostics
updatePositionMap uri changes
-- By default we don't run diagnostics on each change, unless configured
-- by the clietn explicitly
-- by the client explicitly
shouldRunDiag <- configVal diagnosticsOnChange
when shouldRunDiag
(queueDiagnosticsRequest diagIn DiagnosticOnChange tn uri ver)
@ -500,7 +497,7 @@ reactor inp diagIn = do
let
uri = notification ^. J.params . J.textDocument . J.uri
-- unmapFileFromVfs versionTVar cin uri
makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ do
makeRequest $ GReq tn "delete-cache" (Just uri) Nothing Nothing (const $ return ()) () $ do
forM_ (uriToFilePath uri)
deleteCachedModule
return $ IdeResultOk ()
@ -509,13 +506,14 @@ reactor inp diagIn = do
ReqRename req -> do
liftIO $ U.logs $ "reactor:got RenameRequest:" ++ show req
let (params, doc, pos) = reqParams req
newName = params ^. J.newName
callback = reactorSend . RspRename . Core.makeResponseMessage req
let hreq = GReq tn (Just doc) Nothing (Just $ req ^. J.id) callback
$ HaRe.renameCmd' doc pos newName
makeRequest hreq
-- TODO: re-enable HaRe
-- let (params, doc, pos) = reqParams req
-- newName = params ^. J.newName
-- callback = reactorSend . RspRename . Core.makeResponseMessage req
-- let hreq = GReq tn "HaRe-rename" (Just doc) Nothing (Just $ req ^. J.id) callback mempty
-- $ HaRe.renameCmd' doc pos newName
-- makeRequest hreq
reactorSend $ RspRename $ Core.makeResponseMessage req mempty
-- -------------------------------
@ -542,7 +540,7 @@ reactor inp diagIn = do
in reactorSend $ RspHover $ Core.makeResponseMessage req h
hreq :: PluginRequest R
hreq = IReq tn (req ^. J.id) callback $
hreq = IReq tn "hover" (req ^. J.id) callback $
sequence <$> mapM (\hp -> lift $ hp doc pos) hps
makeRequest hreq
liftIO $ U.logs "reactor:HoverRequest done"
@ -572,7 +570,7 @@ reactor inp diagIn = do
case fromDynJSON obj :: Maybe J.WorkspaceEdit of
Just v -> do
lid <- nextLspReqId
reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (J.Object mempty)
reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)
let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v
liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg
reactorSend $ ReqApplyWorkspaceEdit msg
@ -582,13 +580,13 @@ reactor inp diagIn = do
-- The parameters to the HIE command are always the first element
let cmdParams = case args of
Just (J.List (x:_)) -> x
_ -> J.Null
_ -> A.Null
case parseCmdId cmdId of
-- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions
Just ("hie", "fallbackCodeAction") -> do
case J.fromJSON cmdParams of
J.Success (FallbackCodeActionParams mEdit mCmd) -> do
case A.fromJSON cmdParams of
A.Success (FallbackCodeActionParams mEdit mCmd) -> do
-- Send off the workspace request if it has one
forM_ mEdit $ \edit -> do
@ -602,7 +600,7 @@ reactor inp diagIn = do
Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs
-- Otherwise we need to send back a response oureslves
Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (J.Object mempty)
Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty)
-- Couldn't parse the fallback command params
_ -> liftIO $
@ -612,7 +610,7 @@ reactor inp diagIn = do
"Invalid fallbackCodeAction params"
-- Just an ordinary HIE command
Just (plugin, cmd) ->
let preq = GReq tn Nothing Nothing (Just $ req ^. J.id) callback
let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit))
$ runPluginCommand plugin cmd cmdParams
in makeRequest preq
@ -642,7 +640,7 @@ reactor inp diagIn = do
Nothing -> callback []
Just prefix -> do
snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn
let hreq = IReq tn (req ^. J.id) callback
let hreq = IReq tn "completion" (req ^. J.id) callback
$ lift $ Completions.getCompletions doc prefix snippets
makeRequest hreq
@ -653,7 +651,7 @@ reactor inp diagIn = do
callback res = do
let rspMsg = Core.makeResponseMessage req $ res
reactorSend $ RspCompletionItemResolve rspMsg
hreq = IReq tn (req ^. J.id) callback $ runIdeResultT $ do
hreq = IReq tn "completion" (req ^. J.id) callback $ runIdeResultT $ do
lift $ lift $ Completions.resolveCompletion snippets origCompl
makeRequest hreq
@ -663,7 +661,7 @@ reactor inp diagIn = do
liftIO $ U.logs $ "reactor:got DocumentHighlightsRequest:" ++ show req
let (_, doc, pos) = reqParams req
callback = reactorSend . RspDocumentHighlights . Core.makeResponseMessage req . J.List
let hreq = IReq tn (req ^. J.id) callback
let hreq = IReq tn "highlights" (req ^. J.id) callback
$ Hie.getReferencesInDoc doc pos
makeRequest hreq
@ -675,7 +673,7 @@ reactor inp diagIn = do
doc = params ^. J.textDocument . J.uri
pos = params ^. J.position
callback = reactorSend . RspDefinition . Core.makeResponseMessage req
let hreq = IReq tn (req ^. J.id) callback
let hreq = IReq tn "find-def" (req ^. J.id) callback
$ fmap J.MultiLoc <$> Hie.findDef doc pos
makeRequest hreq
@ -685,7 +683,7 @@ reactor inp diagIn = do
doc = params ^. J.textDocument . J.uri
pos = params ^. J.position
callback = reactorSend . RspTypeDefinition . Core.makeResponseMessage req
let hreq = IReq tn (req ^. J.id) callback
let hreq = IReq tn "type-def" (req ^. J.id) callback
$ fmap J.MultiLoc <$> Hie.findTypeDef doc pos
makeRequest hreq
@ -694,7 +692,7 @@ reactor inp diagIn = do
-- TODO: implement project-wide references
let (_, doc, pos) = reqParams req
callback = reactorSend . RspFindReferences. Core.makeResponseMessage req . J.List
let hreq = IReq tn (req ^. J.id) callback
let hreq = IReq tn "references" (req ^. J.id) callback
$ fmap (map (J.Location doc . (^. J.range)))
<$> Hie.getReferencesInDoc doc pos
makeRequest hreq
@ -708,7 +706,7 @@ reactor inp diagIn = do
doc = params ^. J.textDocument . J.uri
withDocumentContents (req ^. J.id) doc $ \text ->
let callback = reactorSend . RspDocumentFormatting . Core.makeResponseMessage req . J.List
hreq = IReq tn (req ^. J.id) callback $ lift $ provider text doc FormatText (params ^. J.options)
hreq = IReq tn "format" (req ^. J.id) callback $ lift $ provider text doc FormatText (params ^. J.options)
in makeRequest hreq
-- -------------------------------
@ -721,7 +719,7 @@ reactor inp diagIn = do
withDocumentContents (req ^. J.id) doc $ \text ->
let range = params ^. J.range
callback = reactorSend . RspDocumentRangeFormatting . Core.makeResponseMessage req . J.List
hreq = IReq tn (req ^. J.id) callback $ lift $ provider text doc (FormatRange range) (params ^. J.options)
hreq = IReq tn "range-format" (req ^. J.id) callback $ lift $ provider text doc (FormatRange range) (params ^. J.options)
in makeRequest hreq
-- -------------------------------
@ -746,7 +744,7 @@ reactor inp diagIn = do
in [si] <> children
callback = reactorSend . RspDocumentSymbols . Core.makeResponseMessage req . convertSymbols . concat
let hreq = IReq tn (req ^. J.id) callback (sequence <$> mapM (\f -> f uri) sps)
let hreq = IReq tn "symbols" (req ^. J.id) callback (sequence <$> mapM (\f -> f uri) sps)
makeRequest hreq
-- -------------------------------
@ -798,7 +796,7 @@ withDocumentContents reqId uri f = do
(J.responseId reqId)
J.InvalidRequest
"Document was not open"
Just (VFS.VirtualFile _ txt) -> f (Rope.toText txt)
Just vf -> f (VFS.virtualFileText vf)
-- | Get the currently configured formatter provider.
-- The currently configured formatter provider is defined in @Config@ by PluginId.
@ -875,10 +873,10 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
let fakeId = J.IdString ("fake,remove:pid=" <> pid) -- TODO:AZ: IReq should take a Maybe LspId
let reql = case ds of
DiagnosticProviderSync dps ->
IReq trackingNumber fakeId callbackl
IReq trackingNumber "diagnostics" fakeId callbackl
$ dps trigger file
DiagnosticProviderAsync dpa ->
IReq trackingNumber fakeId pure
IReq trackingNumber "diagnostics-a" fakeId pure
$ dpa trigger file callbackl
-- This callback is used in R for the dispatcher normally,
-- but also in IO if the plugin chooses to spawn an
@ -915,21 +913,21 @@ requestDiagnosticsNormal tn file mVer = do
hasSeverity :: J.DiagnosticSeverity -> J.Diagnostic -> Bool
hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev
hasSeverity _ _ = False
sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])
sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])])
maxToSend = maxNumberOfProblems clientConfig
let sendHlint = hlintOn clientConfig
when sendHlint $ do
-- get hlint diagnostics
let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl
let reql = GReq tn "apply-refact" (Just file) (Just (file,ver)) Nothing callbackl (PublishDiagnosticsParams file mempty)
$ ApplyRefact.lintCmd' file
callbackl (PublishDiagnosticsParams fp (List ds))
= sendOne "hlint" (J.toNormalizedUri fp, ds)
makeRequest reql
-- get GHC diagnostics and loads the typechecked module into the cache
let reqg = GReq tn (Just file) (Just (file,ver)) Nothing callbackg
$ HIE.setTypecheckedModule file
let reqg = GReq tn "typecheck" (Just file) (Just (file,ver)) Nothing callbackg mempty
$ BIOS.setTypecheckedModule file
callbackg (HIE.Diagnostics pd, errs) = do
forM_ errs $ \e -> do
reactorSend $ NotShowMessage $
@ -938,7 +936,9 @@ requestDiagnosticsNormal tn file mVer = do
let ds = Map.toList $ S.toList <$> pd
case ds of
[] -> sendEmpty
_ -> mapM_ (sendOneGhc "ghcmod") ds
_ -> do
debugm ("Diags: " ++ show ds)
mapM_ (sendOneGhc "bios") ds
makeRequest reqg
@ -985,7 +985,7 @@ hieOptions commandIds =
hieHandlers :: TChan ReactorInput -> Core.Handlers
hieHandlers rin
= def { Core.initializedHandler = Just $ passHandler rin NotInitialized
, Core.renameHandler = Just $ passHandler rin ReqRename
-- , Core.renameHandler = Just $ passHandler rin ReqRename
, Core.definitionHandler = Just $ passHandler rin ReqDefinition
, Core.typeDefinitionHandler = Just $ passHandler rin ReqTypeDefinition
, Core.referencesHandler = Just $ passHandler rin ReqFindReferences

11
src/Haskell/Ide/Engine/Types.hs
View File

@ -18,30 +18,35 @@ type TrackingNumber = Int
-- | Requests are parametric in the monad m
-- that their callback expects to be in.
pattern GReq :: TrackingNumber
-> String
-> Maybe Uri
-> Maybe (Uri, Int)
-> Maybe J.LspId
-> RequestCallback m a1
-> a1
-> IdeGhcM (IdeResult a1)
-> PluginRequest m
pattern GReq a b c d e f = Right (GhcRequest a b c d e f)
pattern GReq a s b c d e f g = Right (GhcRequest a s b c d e f g)
pattern IReq :: TrackingNumber -> J.LspId -> RequestCallback m a -> IdeDeferM (IdeResult a) -> Either (IdeRequest m) b
pattern IReq a b c d = Left (IdeRequest a b c d)
pattern IReq :: TrackingNumber -> String -> J.LspId -> RequestCallback m a -> IdeDeferM (IdeResult a) -> Either (IdeRequest m) b
pattern IReq a s b c d = Left (IdeRequest a s b c d)
type PluginRequest m = Either (IdeRequest m) (GhcRequest m)
data GhcRequest m = forall a. GhcRequest
{ pinMsgNum :: TrackingNumber -- ^ Exists to facilitate logging/tracing
, pinDesc :: String -- ^ Description of the request for debugging
, pinContext :: Maybe J.Uri
, pinDocVer :: Maybe (J.Uri, Int)
, pinLspReqId :: Maybe J.LspId
, pinCallback :: RequestCallback m a
, pinDefault :: a
, pinReq :: IdeGhcM (IdeResult a)
}
data IdeRequest m = forall a. IdeRequest
{ pureMsgNum :: TrackingNumber -- ^ Exists to facilitate logging/tracing
, pureDesc :: String
, pureReqId :: J.LspId
, pureReqCallback :: RequestCallback m a
, pureReq :: IdeDeferM (IdeResult a)

38
stack-8.4.2.yaml
View File

@ -1,43 +1,59 @@
resolver: nightly-2018-05-30 # last nightly for GHC 8.4.2
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.1.0
- base-compat-0.9.3
- cabal-plan-0.3.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- connection-0.3.1 # for network and network-bsd
- constrained-dynamic-0.1.0.0
- ghc-exactprint-0.6.2 # for HaRe
- filepattern-0.1.1
- floskell-0.10.2
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-8.8.1
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- hslogger-1.3.1.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- network-3.1.1.1 # for hslogger
- network-bsd-2.8.1.0 # for hslogger
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- simple-sendfile-0.2.30 # for network and network-bsd
- socks-0.6.1 # for network and network-bsd
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- windns-0.1.0.0
- yaml-0.8.32
- yi-rope-0.11
- time-manager-0.0.0 # for http2
- warp-3.2.28 # for network and network-bsd
- wai-3.2.2.1 # for network and network-bsd
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325
- libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:

37
stack-8.4.3.yaml
View File

@ -1,40 +1,57 @@
resolver: lts-12.14 # Last for GHC 8.4.3
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- base-compat-0.9.3
- brittany-0.12.1.0
- cabal-plan-0.3.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- connection-0.3.1 # for network and network-bsd
- constrained-dynamic-0.1.0.0
- ghc-exactprint-0.6.2 # for HaRe
- filepattern-0.1.1
- floskell-0.10.2
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-8.8.1
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- hslogger-1.3.1.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- network-3.1.1.1 # for hslogger
- network-bsd-2.8.1.0 # for hslogger
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- simple-sendfile-0.2.30 # for network and network-bsd
- socks-0.6.1 # for network and network-bsd
# To make build work in windows 7
- unix-time-0.4.7
- temporary-1.2.1.1
- time-manager-0.0.0 # for http2
- warp-3.2.28 # for network and network-bsd
- wai-3.2.2.1 # for network and network-bsd
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325
- libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:

36
stack-8.4.4.yaml
View File

@ -1,40 +1,56 @@
resolver: lts-12.26 # LTS 12.15 is first to support GHC 8.4.4
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.1.0
- cabal-plan-0.4.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- connection-0.3.1 # for network and network-bsd
- constrained-dynamic-0.1.0.0
- ghc-exactprint-0.6.2 # for HaRe
- filepattern-0.1.1
- floskell-0.10.2
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-8.8.1
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- hslogger-1.3.1.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- network-3.1.1.1 # for hslogger
- network-bsd-2.8.1.0 # for hslogger
- optparse-simple-0.1.0
- pretty-show-1.9.5
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- simple-sendfile-0.2.30 # for network and network-bsd
- socks-0.6.1 # for network and network-bsd
# To make build work in windows 7
- unix-time-0.4.7
- temporary-1.2.1.1
- time-manager-0.0.0 # for http2
- warp-3.2.28 # for network and network-bsd
- wai-3.2.2.1 # for network and network-bsd
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
- file-embed-0.0.11@sha256:77bb3b1dc219ccd682706b1d3dfbc5bf2db5beb1af6c108ed9e0f5b4d58a5a0a,1325
- libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090
flags:
haskell-ide-engine:

26
stack-8.6.1.yaml
View File

@ -1,20 +1,19 @@
resolver: nightly-2018-11-11 # Last GHC 8.6.1
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- apply-refact-0.6.0.0
- brittany-0.12.1.0
- butcher-1.3.2.3
- bytestring-trie-0.2.5.0
- cabal-install-2.4.0.0
- cabal-plan-0.4.0.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- czipwith-1.0.1.1
- data-tree-print-0.1.0.2
@ -22,15 +21,17 @@ extra-deps:
- filepattern-0.1.1
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- ghc-exactprint-0.6.2 # for HaRe
- haddock-api-2.21.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- monoid-subclasses-0.4.6.1
@ -43,7 +44,12 @@ extra-deps:
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:

27
stack-8.6.2.yaml
View File

@ -1,32 +1,33 @@
resolver: nightly-2018-12-17 # Last GHC 8.6.2
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.1.0
- butcher-1.3.2.3
- cabal-plan-0.4.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- deque-0.4.3
- filepattern-0.1.1
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- ghc-exactprint-0.6.2 # for HaRe
- haddock-api-2.21.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- multistate-0.8.0.1
@ -36,7 +37,13 @@ extra-deps:
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
#- hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- libyaml-0.1.1.0@sha256:b3fcd8c44622c75e054c2267f3fec39a58a311748000310cbc8257a4683d3f02,2090
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:

25
stack-8.6.3.yaml
View File

@ -1,30 +1,31 @@
resolver: lts-13.10 # Last GHC 8.6.3
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.1.0
- bytestring-trie-0.2.5.0
- butcher-1.3.2.1
- cabal-plan-0.4.0.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- ghc-exactprint-0.6.2 # for HaRe
- haddock-api-2.21.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- haskell-src-exts-util-0.2.5
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- multistate-0.8.0.1
@ -34,7 +35,11 @@ extra-deps:
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:

27
stack-8.6.4.yaml
View File

@ -1,29 +1,30 @@
resolver: lts-13.19 # GHC 8.6.4
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.1.0
- butcher-1.3.2.1
- cabal-plan-0.4.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- ghc-exactprint-0.6.2 # for HaRe
- haddock-api-2.22.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- haskell-src-exts-1.21.1
- hie-bios-0.3.2
- hlint-2.2.4
- hoogle-5.0.17.11
- hsimport-0.11.0
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2@rev:1
- monad-memo-0.4.1
- multistate-0.8.0.1
@ -32,7 +33,12 @@ extra-deps:
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af
- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb
- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76
- unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204
flags:
haskell-ide-engine:
@ -40,6 +46,7 @@ flags:
hie-plugin-api:
pedantic: true
# allow-newer: true
nix:

20
stack-8.6.5.yaml
View File

@ -1,32 +1,34 @@
resolver: lts-14.16
packages:
- .
- hie-plugin-api
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- ansi-terminal-0.8.2
- ansi-wl-pprint-0.6.8.2
- brittany-0.12.1.0
- cabal-plan-0.4.0.0
- bytestring-trie-0.2.5.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- ghc-exactprint-0.6.2 # for HaRe
- haddock-api-2.22.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- hie-bios-0.3.2
- hlint-2.2.4
- hsimport-0.11.0
- hoogle-5.0.17.11
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2@rev:1
- syz-0.2.0.0
- temporary-1.2.1.1
- clock-0.7.2
flags:
haskell-ide-engine:

21
stack.yaml
View File

@ -4,28 +4,34 @@ packages:
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
# - ./submodules/HaRe
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- deque-0.4.3
- ansi-terminal-0.8.2
- bytestring-trie-0.2.5.0
- ansi-wl-pprint-0.6.8.2
- brittany-0.12.1.0
- cabal-plan-0.4.0.0
- cabal-plan-0.5.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.2
- ghc-lib-parser-8.8.1
- haddock-api-2.22.0
- haskell-lsp-0.18.0.0
- haskell-lsp-types-0.18.0.0
- haskell-lsp-0.19.0.0
- haskell-lsp-types-0.19.0.0
- hie-bios-0.3.2
- hlint-2.2.4
- hsimport-0.11.0
- lsp-test-0.8.2.0
- lsp-test-0.9.0.0
- monad-dijkstra-0.1.1.2@rev:1
- syz-0.2.0.0
- temporary-1.2.1.1
- clock-0.7.2
- ghc-exactprint-0.6.2 # for HaRe
- extra-1.6.18
- unix-compat-0.5.2
- yaml-0.11.1.2
flags:
haskell-ide-engine:
@ -33,6 +39,7 @@ flags:
hie-plugin-api:
pedantic: true
# allow-newer: true
nix:

1
submodules/HaRe

@ -1 +0,0 @@
Subproject commit dfab0004320c28e1aa0331a507a9428952f2c938

2
submodules/cabal-helper

@ -1 +1 @@
Subproject commit eafed5e8c1d82b8daa35775b52361132f2e70261
Subproject commit a41af44159ac525a913be8ece11da8583706ec1a

2
submodules/ghc-mod

@ -1 +1 @@
Subproject commit 910887b2c33237b703417ec07f35ca8bbf35d729
Subproject commit 7757a149a6ddb243679840ebff8949ff305c3424

66
test/dispatcher/Main.hs
View File

@ -7,7 +7,7 @@ import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Monad.STM
import Data.Aeson
import qualified Data.HashMap.Strict as H
-- import qualified Data.HashMap.Strict as H
import Data.Typeable
import qualified Data.Text as T
import Data.Default
@ -25,6 +25,7 @@ import System.FilePath
import Test.Hspec
import Test.Hspec.Runner
import System.IO
-- ---------------------------------------------------------------------
-- plugins
@ -32,15 +33,17 @@ import Test.Hspec.Runner
import Haskell.Ide.Engine.Plugin.ApplyRefact
import Haskell.Ide.Engine.Plugin.Base
import Haskell.Ide.Engine.Plugin.Example2
import Haskell.Ide.Engine.Plugin.GhcMod
import Haskell.Ide.Engine.Plugin.HaRe
-- import Haskell.Ide.Engine.Plugin.HaRe
import Haskell.Ide.Engine.Plugin.Bios
import Haskell.Ide.Engine.Plugin.Generic
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
-- ---------------------------------------------------------------------
main :: IO ()
main = do
setupStackFiles
hSetBuffering stderr LineBuffering
setupBuildToolFiles
config <- getHspecFormattedConfig "dispatcher"
withFileLogging "main-dispatcher.log" $ do
hspecWith config funcSpec
@ -62,8 +65,7 @@ plugins :: IdePlugins
plugins = pluginDescToIdePlugins
[applyRefactDescriptor "applyrefact"
,example2Descriptor "eg2"
,ghcmodDescriptor "ghcmod"
,hareDescriptor "hare"
,biosDescriptor "bios"
,baseDescriptor "base"
]
@ -83,7 +85,7 @@ startServer = do
-- ---------------------------------------------------------------------
type LogVal = (String, Either (LspId, ErrorCode, T.Text) DynamicJSON)
type LogVal = (String, Either (Maybe LspId, ErrorCode, T.Text) DynamicJSON)
logToChan :: TChan LogVal -> LogVal -> IO ()
logToChan c t = atomically $ writeTChan c t
@ -91,17 +93,17 @@ logToChan c t = atomically $ writeTChan c t
-- ---------------------------------------------------------------------
dispatchGhcRequest :: ToJSON a
=> TrackingNumber -> String -> Int
=> TrackingNumber -> Maybe Uri -> String -> Int
-> Scheduler IO -> TChan LogVal
-> PluginId -> CommandName -> a -> IO ()
dispatchGhcRequest tn ctx n scheduler lc plugin com arg = do
dispatchGhcRequest tn uri ctx n scheduler lc plugin com arg = do
let
logger :: RequestCallback IO DynamicJSON
logger x = logToChan lc (ctx, Right x)
let req = GReq tn Nothing Nothing (Just (IdInt n)) logger $
let req = GReq tn "plugin-command" uri Nothing (Just (IdInt n)) logger (toDynJSON (Nothing :: Maybe ())) $
runPluginCommand plugin com (toJSON arg)
sendRequest scheduler Nothing req
sendRequest scheduler req
dispatchIdeRequest :: (Typeable a, ToJSON a)
@ -112,8 +114,8 @@ dispatchIdeRequest tn ctx scheduler lc lid f = do
logger :: (Typeable a, ToJSON a) => RequestCallback IO a
logger x = logToChan lc (ctx, Right (toDynJSON x))
let req = IReq tn lid logger f
sendRequest scheduler Nothing req
let req = IReq tn "dispatch" lid logger f
sendRequest scheduler req
-- ---------------------------------------------------------------------
@ -146,6 +148,7 @@ funcSpec = describe "functional dispatch" $ do
unpackRes (r,Right md) = (r, fromDynJSON md)
unpackRes r = error $ "unpackRes:" ++ show r
-- ---------------------------------
it "defers responses until module is loaded" $ do
@ -162,7 +165,7 @@ funcSpec = describe "functional dispatch" $ do
show rrr `shouldBe` "Nothing"
-- need to typecheck the module to trigger deferred response
dispatchGhcRequest 2 "req2" 2 scheduler logChan "ghcmod" "check" (toJSON testUri)
dispatchGhcRequest 2 (Just testUri) "req2" 2 scheduler logChan "bios" "check" (toJSON testUri)
-- And now we get the deferred response (once the module is loaded)
("req1",Right res) <- atomically $ readTChan logChan
@ -185,6 +188,8 @@ funcSpec = describe "functional dispatch" $ do
hr3 <- atomically $ readTChan logChan
unpackRes hr3 `shouldBe` ("IReq IdInt 3",Just Cached)
-- ---------------------------------
it "instantly responds to deferred requests if cache is available" $ do
-- deferred responses should return something now immediately
-- as long as the above test ran before
@ -238,9 +243,11 @@ funcSpec = describe "functional dispatch" $ do
}
])
-- -----------------------------------------------------
it "returns hints as diagnostics" $ do
dispatchGhcRequest 5 "r5" 5 scheduler logChan "applyrefact" "lint" testUri
dispatchGhcRequest 5 (Just testUri) "r5" 5 scheduler logChan "applyrefact" "lint" testUri
hr5 <- atomically $ readTChan logChan
unpackRes hr5 `shouldBe` ("r5",
@ -258,24 +265,29 @@ funcSpec = describe "functional dispatch" $ do
}
)
let req6 = HP testUri (toPos (8, 1))
dispatchGhcRequest 6 "r6" 6 scheduler logChan "hare" "demote" req6
-- let req6 = HP testUri (toPos (8, 1))
-- dispatchGhcRequest 6 (Just testUri) "r6" 6 scheduler logChan "hare" "demote" req6
--
-- hr6 <- atomically $ readTChan logChan
-- -- show hr6 `shouldBe` "hr6"
-- let textEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
-- r6uri = testUri
-- unpackRes hr6 `shouldBe` ("r6",Just
-- (WorkspaceEdit
-- (Just $ H.singleton r6uri textEdits)
-- Nothing
-- ))
dispatchGhcRequest 6 (Just testUri) "r6" 6 scheduler logChan "bios" "check" (toJSON testUri)
hr6 <- atomically $ readTChan logChan
-- show hr6 `shouldBe` "hr6"
let textEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
r6uri = testUri
unpackRes hr6 `shouldBe` ("r6",Just
(WorkspaceEdit
(Just $ H.singleton r6uri textEdits)
Nothing
))
unpackRes hr6 `shouldBe` ("r6",Nothing :: Maybe Int)
-- -----------------------------------------------------
it "instantly responds to failed modules with no cache with the default" $ do
dispatchIdeRequest 7 "req7" scheduler logChan (IdInt 7) $ findDef testFailUri (Position 1 2)
dispatchGhcRequest 8 "req8" 8 scheduler logChan "ghcmod" "check" (toJSON testFailUri)
dispatchGhcRequest 8 (Just testUri) "req8" 8 scheduler logChan "bios" "check" (toJSON testFailUri)
hr7 <- atomically $ readTChan logChan
unpackRes hr7 `shouldBe` ("req7", Just ([] :: [Location]))

44
test/functional/DeferredSpec.hs
View File

@ -7,8 +7,8 @@ import Control.Applicative.Combinators
import Control.Monad.IO.Class
import Control.Lens hiding (List)
import Control.Monad
import Data.Aeson
import qualified Data.HashMap.Strict as H
-- import Data.Aeson
-- import qualified Data.HashMap.Strict as H
import Data.Maybe
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
@ -91,16 +91,22 @@ spec = do
}
]
-- -----------------------------------
it "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "FuncTestFail.hs" "haskell"
defs <- getDefinitions doc (Position 1 11)
liftIO $ defs `shouldBe` []
it "respond to untypecheckable modules with parsed module cache" $
runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "FuncTestFail.hs" "haskell"
(Left (sym:_)) <- getDocumentSymbols doc
liftIO $ sym ^. name `shouldBe` "main"
-- TODO: the benefits of caching parsed modules is doubted.
-- TOOD: add issue link
-- it "respond to untypecheckable modules with parsed module cache" $
-- runSession hieCommand fullCaps "test/testdata" $ do
-- doc <- openDoc "FuncTestFail.hs" "haskell"
-- (Left (sym:_)) <- getDocumentSymbols doc
-- liftIO $ sym ^. name `shouldBe` "main"
-- -----------------------------------
it "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do
_ <- openDoc "FuncTest.hs" "haskell"
@ -123,18 +129,18 @@ spec = do
}
)
let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)]
args = List [Object args']
-- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)]
-- args = List [Object args']
--
-- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing)
-- liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty)
executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing)
liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty)
editReq <- message :: Session ApplyWorkspaceEditRequest
let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit
Nothing
(Just expectedTextDocEdits)
-- editReq <- message :: Session ApplyWorkspaceEditRequest
-- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"]
-- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits]
-- liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit
-- Nothing
-- (Just expectedTextDocEdits)
-- -----------------------------------
@ -153,7 +159,7 @@ spec = do
describe "multiple main modules" $
it "Can load one file at a time, when more than one Main module exists"
-- $ runSession hieCommand fullCaps "test/testdata" $ do
$ runSession hieCommandVomit fullCaps "test/testdata" $ do
$ runSession hieCommand fullCaps "test/testdata" $ do
_doc <- openDoc "ApplyRefact2.hs" "haskell"
_diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification
diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification

15
test/functional/DefinitionSpec.hs
View File

@ -1,5 +1,6 @@
module DefinitionSpec where
-- import Control.Applicative.Combinators
import Control.Lens
import Control.Monad.IO.Class
import Language.Haskell.LSP.Test
@ -17,6 +18,8 @@ spec = describe "definitions" $ do
let expRange = Range (Position 4 0) (Position 4 3)
liftIO $ defs `shouldBe` [Location (doc ^. uri) expRange]
-- -----------------------------------
it "goto's imported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
doc <- openDoc "Foo.hs" "haskell"
defs <- getDefinitions doc (Position 2 8)
@ -24,6 +27,8 @@ spec = describe "definitions" $ do
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
-- -----------------------------------
it "goto's exported modules" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
doc <- openDoc "Foo.hs" "haskell"
defs <- getDefinitions doc (Position 0 15)
@ -31,6 +36,8 @@ spec = describe "definitions" $ do
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
-- -----------------------------------
it "goto's imported modules that are loaded" $ runSession hieCommand fullCaps "test/testdata/definition" $ do
doc <- openDoc "Foo.hs" "haskell"
_ <- openDoc "Bar.hs" "haskell"
@ -39,15 +46,23 @@ spec = describe "definitions" $ do
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
-- -----------------------------------
it "goto's imported modules that are loaded, and then closed" $
runSession hieCommand fullCaps "test/testdata/definition" $ do
doc <- openDoc "Foo.hs" "haskell"
otherDoc <- openDoc "Bar.hs" "haskell"
closeDoc otherDoc
defs <- getDefinitions doc (Position 2 8)
_ <- waitForDiagnostics
liftIO $ putStrLn "D"
liftIO $ do
fp <- canonicalizePath "test/testdata/definition/Bar.hs"
defs `shouldBe` [Location (filePathToUri fp) zeroRange]
liftIO $ putStrLn "E" -- AZ
noDiagnostics
zeroRange :: Range
zeroRange = Range (Position 0 0) (Position 0 0)

4
test/functional/DiagnosticsSpec.hs
View File

@ -65,14 +65,14 @@ spec = describe "diagnostics providers" $ do
it "is deferred" $
runSession hieCommand fullCaps "test/testdata" $ do
_ <- openDoc "TypedHoles.hs" "haskell"
[diag] <- waitForDiagnosticsSource "ghcmod"
[diag] <- waitForDiagnosticsSource "bios"
liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning
describe "Warnings are warnings" $
it "Overrides -Werror" $
runSession hieCommand fullCaps "test/testdata/wErrorTest" $ do
_ <- openDoc "src/WError.hs" "haskell"
[diag] <- waitForDiagnosticsSource "ghcmod"
[diag] <- waitForDiagnosticsSource "bios"
liftIO $ diag ^. LSP.severity `shouldBe` Just DsWarning
describe "only diagnostics on save" $

56
test/functional/FunctionalBadProjectSpec.hs
View File

@ -2,37 +2,41 @@
module FunctionalBadProjectSpec where
import Control.Lens hiding (List)
import Control.Monad.IO.Class
import qualified Data.Text as T
import Language.Haskell.LSP.Test hiding (message)
import Language.Haskell.LSP.Types as LSP
import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error )
-- import Control.Lens hiding (List)
-- import Control.Monad.IO.Class
-- import qualified Data.Text as T
-- import Language.Haskell.LSP.Test hiding (message)
-- import Language.Haskell.LSP.Types as LSP
-- import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error )
import Test.Hspec
import TestUtils
import Utils
-- import TestUtils
-- import Utils
-- ---------------------------------------------------------------------
-- TODO: Currently this can not succeed, since such an error is thrown in "runActionWithContext" which
-- can produce diagnostics at the moment. Needs more investigation
-- TODO: @fendor: Add issue link here
--
spec :: Spec
spec = describe "behaviour on malformed projects" $ do
it "deals with cabal file with unsatisfiable dependency" $
runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do
-- runSessionWithConfig logConfig hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
_doc <- openDoc "Foo.hs" "haskell"
spec = describe "behaviour on malformed projects" $
it "no test executed" $ True `shouldBe` True
-- it "deals with cabal file with unsatisfiable dependency" $
-- runSession hieCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do
-- -- runSessionWithConfig logConfig hieCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do
-- _doc <- openDoc "Foo.hs" "haskell"
diags@(d:_) <- waitForDiagnosticsSource "ghcmod"
-- liftIO $ show diags `shouldBe` ""
-- liftIO $ putStrLn $ show diags
-- liftIO $ putStrLn "a"
liftIO $ do
length diags `shouldBe` 1
d ^. range `shouldBe` Range (Position 0 0) (Position 1 0)
d ^. severity `shouldBe` (Just DsError)
d ^. code `shouldBe` Nothing
d ^. source `shouldBe` Just "ghcmod"
d ^. message `shouldBe`
(T.pack "readCreateProcess: stack \"build\" \"--only-configure\" \".\" (exit 1): failed\n")
-- diags@(d:_) <- waitForDiagnosticsSource "bios"
-- -- liftIO $ show diags `shouldBe` ""
-- -- liftIO $ putStrLn $ show diags
-- -- liftIO $ putStrLn "a"
-- liftIO $ do
-- length diags `shouldBe` 1
-- d ^. range `shouldBe` Range (Position 0 0) (Position 1 0)
-- d ^. severity `shouldBe` (Just DsError)
-- d ^. code `shouldBe` Nothing
-- d ^. source `shouldBe` Just "bios"
-- d ^. message `shouldBe`
-- (T.pack "readCreateProcess: stack \"build\" \"--only-configure\" \".\" (exit 1): failed\n")
-- ---------------------------------

99
test/functional/FunctionalCodeActionsSpec.hs
View File

@ -21,6 +21,8 @@ import qualified Language.Haskell.LSP.Types.Capabilities as C
import Test.Hspec
import TestUtils
{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}
spec :: Spec
spec = describe "code actions" $ do
describe "hlint suggestions" $ do
@ -46,7 +48,7 @@ spec = describe "code actions" $ do
contents <- getDocumentEdit doc
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
noDiagnostics
-- noDiagnostics
-- ---------------------------------
@ -65,7 +67,9 @@ spec = describe "code actions" $ do
contents <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
noDiagnostics
-- noDiagnostics
-- ---------------------------------
it "runs diagnostics on save" $ runSession hieCommand fullCaps "test/testdata" $ do
let config = def { diagnosticsOnChange = False }
@ -92,7 +96,7 @@ spec = describe "code actions" $ do
liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n"
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
noDiagnostics
-- noDiagnostics
-- -----------------------------------
@ -100,7 +104,7 @@ spec = describe "code actions" $ do
it "works" $ runSession hieCommand noLiteralCaps "test/testdata" $ do
doc <- openDoc "CodeActionRename.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
CACommand cmd:_ <- getAllCodeActions doc
executeCommand cmd
@ -111,7 +115,7 @@ spec = describe "code actions" $ do
runSession hieCommand noLiteralCaps "test/testdata" $ do
doc <- openDoc "CodeActionRename.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
CACommand cmd <- (!! 2) <$> getAllCodeActions doc
let Just (List [Object args]) = cmd ^. L.arguments
@ -126,6 +130,9 @@ spec = describe "code actions" $ do
liftIO $ x `shouldBe` "foo = putStrLn \"world\""
describe "import suggestions" $ do
-- ---------------------------------
describe "formats with brittany" $ hsImportSpec "brittany"
[ -- Expected output for simple format.
[ "import qualified Data.Maybe"
@ -245,7 +252,7 @@ spec = describe "code actions" $ do
doc <- openDoc "app/Asdf.hs" "haskell"
-- ignore the first empty hlint diagnostic publish
[_,diag:_] <- count 2 waitForDiagnostics
[_,_:diag:_] <- count 2 waitForDiagnostics
let prefixes = [ "Could not load module `Codec.Compression.GZip'" -- Windows && GHC >= 8.6
, "Could not find module `Codec.Compression.GZip'" -- Windows
@ -303,7 +310,7 @@ spec = describe "code actions" $ do
-- provides workspace edit property which skips round trip to
-- the server
contents <- documentContents doc
liftIO $ contents `shouldBe` "main :: IO ()\nmain = putStrLn \"hello\""
liftIO $ contents `shouldBe` "module CodeActionRedundant where\nmain :: IO ()\nmain = putStrLn \"hello\""
it "doesn't touch other imports" $ runSession hieCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
doc <- openDoc "src/MultipleImports.hs" "haskell"
@ -328,7 +335,7 @@ spec = describe "code actions" $ do
it "works" $
runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "TypedHoles.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
cas <- map (\(CACodeAction x)-> x) <$> getAllCodeActions doc
suggestion <-
@ -368,7 +375,7 @@ spec = describe "code actions" $ do
it "shows more suggestions" $
runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "TypedHoles2.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
cas <- map fromAction <$> getAllCodeActions doc
suggestion <-
@ -416,7 +423,7 @@ spec = describe "code actions" $ do
runSession hieCommand fullCaps "test/testdata/" $ do
doc <- openDoc "TopLevelSignature.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ map (^. L.title) cas `shouldContain` [ "Add signature: main :: IO ()"]
@ -442,7 +449,7 @@ spec = describe "code actions" $ do
runSession hieCommand fullCaps "test/testdata/addPragmas" $ do
doc <- openDoc "NeedsPragmas.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ map (^. L.title) cas `shouldContain` [ "Add \"TypeSynonymInstances\""]
@ -475,29 +482,31 @@ spec = describe "code actions" $ do
-- -----------------------------------
describe "unused term code actions" $
it "Prefixes with '_'" $
runSession hieCommand fullCaps "test/testdata/" $ do
doc <- openDoc "UnusedTerm.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
cas <- map fromAction <$> getAllCodeActions doc
liftIO $ map (^. L.title) cas `shouldContain` [ "Prefix imUnused with _"]
executeCodeAction $ head cas
edit <- getDocumentEdit doc
let expected = [ "{-# OPTIONS_GHC -Wall #-}"
, "module UnusedTerm () where"
, "_imUnused :: Int -> Int"
, "_imUnused 1 = 1"
, "_imUnused 2 = 2"
, "_imUnused _ = 3"
]
liftIO $ edit `shouldBe` T.unlines expected
it "Prefixes with '_'" $ pendingWith "removed because of HaRe"
-- runSession hieCommand fullCaps "test/testdata/" $ do
-- doc <- openDoc "UnusedTerm.hs" "haskell"
--
-- _ <- waitForDiagnosticsSource "bios"
-- cas <- map fromAction <$> getAllCodeActions doc
--
-- liftIO $ map (^. L.title) cas `shouldContain` [ "Prefix imUnused with _"]
--
-- executeCodeAction $ head cas
--
-- edit <- getDocumentEdit doc
--
-- let expected = [ "{-# OPTIONS_GHC -Wall #-}"
-- , "module UnusedTerm () where"
-- , "_imUnused :: Int -> Int"
-- , "_imUnused 1 = 1"
-- , "_imUnused 2 = 2"
-- , "_imUnused _ = 3"
-- ]
--
-- liftIO $ edit `shouldBe` T.unlines expected
-- See https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#textDocument_codeAction
-- `CodeActionContext`
it "respect 'only' parameter" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionOnly.hs" "haskell"
_ <- count 2 waitForDiagnostics -- need to wait for both hlint and ghcmod
@ -508,7 +517,8 @@ spec = describe "code actions" $ do
let cas = map fromAction res
kinds = map (^. L.kind) cas
liftIO $ do
kinds `shouldNotSatisfy` null
-- TODO: When HaRe is back this should be uncommented
-- kinds `shouldNotSatisfy` null
kinds `shouldNotSatisfy` any (Just CodeActionRefactorInline /=)
kinds `shouldSatisfy` all (Just CodeActionRefactorInline ==)
@ -550,7 +560,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
it "formats" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportBrittany.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -564,7 +574,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
it "import-list formats" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportBrittany.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -576,6 +586,8 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
contents <- getDocumentEdit doc
liftIO $ T.lines contents `shouldMatchList` e2
-- ---------------------------------
it "multiple import-list formats" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportList.hs" "haskell"
@ -592,6 +604,8 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
liftIO $ Set.fromList (T.lines contents) `shouldBe` Set.fromList e3
-- ---------------------------------
it "respects format config, multiple import-list" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportList.hs" "haskell"
@ -619,7 +633,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
]
it "respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportBrittany.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formatOnImportOn = False, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -638,7 +652,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
it "import-list respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportBrittany.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formatOnImportOn = False, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -657,7 +671,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
it "complex import-list" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportListElaborate.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formatOnImportOn = True, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -678,7 +692,7 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
it "complex import-list respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportListElaborate.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
let config = def { formatOnImportOn = False, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
@ -714,10 +728,10 @@ hsImportSpec formatterName [e1, e2, e3, e4] =
executeAllCodeActions :: TextDocumentIdentifier -> [T.Text] -> Session T.Text
executeAllCodeActions doc names =
foldM (\_ _ -> do
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
executeCodeActionByName doc names
content <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
_ <- waitForDiagnosticsSource "ghcmod"
_ <- waitForDiagnosticsSource "bios"
return content
)
(T.pack "")
@ -742,6 +756,7 @@ hsImportSpec formatter args =
++ T.unpack formatter
++ ")\", expected 4, got "
++ show (length args)
-- ---------------------------------------------------------------------
fromAction :: CAResult -> CodeAction

15
test/functional/FunctionalLiquidSpec.hs
View File

@ -86,13 +86,16 @@ spec = describe "liquid haskell diagnostics" $ do
-- docItem <- getDocItem file languageId
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
diags2hlint <- waitForDiagnostics
-- liftIO $ show diags2hlint `shouldBe` ""
-- TODO: what does that test?
-- TODO: whether hlint is really disbabled?
-- TODO: @fendor, document or remove
-- diags2hlint <- waitForDiagnostics
-- -- liftIO $ show diags2hlint `shouldBe` ""
-- We turned hlint diagnostics off
liftIO $ length diags2hlint `shouldBe` 0
diags2liquid <- waitForDiagnostics
liftIO $ length diags2liquid `shouldBe` 0
-- -- We turned hlint diagnostics off
-- liftIO $ length diags2hlint `shouldBe` 0
-- diags2liquid <- waitForDiagnostics
-- liftIO $ length diags2liquid `shouldBe` 0
-- liftIO $ show diags2liquid `shouldBe` ""
diags3@(d:_) <- waitForDiagnosticsSource "liquid"
-- liftIO $ show diags3 `shouldBe` ""

80
test/functional/HaReSpec.hs
View File

@ -1,80 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module HaReSpec where
import Control.Applicative.Combinators
import Control.Monad.IO.Class
import Data.Maybe
import qualified Data.Text as T
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Test.Hspec
import TestUtils
spec :: Spec
spec = describe "HaRe" $
context "code actions" $ do
context "lift one level" $
it "works" $
let r = Range (Position 2 8) (Position 2 17)
expected =
"module HaReLift where\n\
\foo = bar\n\n\
\bar = \"hello\""
in execCodeAction "HaReLift.hs" r "Lift bar one level" expected
context "lift to top level" $
it "works" $
let r = Range (Position 2 8) (Position 2 17)
expected =
"module HaReLift where\n\
\foo = bar\n\n\
\bar = \"hello\""
in execCodeAction "HaReLift.hs" r "Lift bar to top level" expected
context "delete definition" $
it "works" $
let r = Range (Position 1 0) (Position 1 4)
expected = "module HaReLift where\n"
in execCodeAction "HaReLift.hs" r "Delete definition of foo" expected
context "duplicate definition" $
it "works" $
let r = Range (Position 1 0) (Position 1 4)
expected =
"module HaReLift where\n\
\foo = bar\n\
\ where bar = \"hello\"\n\
\foo' = bar\n\
\ where bar = \"hello\"\n"
in execCodeAction "HaReLift.hs" r "Duplicate definition of foo" expected
context "demote definition" $ it "works" $
let r = Range (Position 5 0) (Position 5 1)
expected = "\nmain = putStrLn \"hello\"\n\n\
\foo x = y + 3\n where\n y = 7\n"
in execCodeAction "HaReDemote.hs" r "Demote y one level" expected
context "casesplit argument" $ it "works" $
let r = Range (Position 4 5) (Position 4 6)
expected = "\nmain = putStrLn \"hello\"\n\n\
\foo :: Maybe Int -> ()\n\
\foo Nothing = ()\n\
\foo (Just x) = ()\n"
in execCodeAction "GhcModCaseSplit.hs" r "Case split on x" expected
getCANamed :: T.Text -> [CAResult] -> CodeAction
getCANamed named = head . mapMaybe test
where test (CACodeAction ca@(CodeAction t _ _ _ _))
| named `T.isInfixOf` t = Just ca
| otherwise = Nothing
test _ = Nothing
execCodeAction :: String -> Range -> T.Text -> T.Text -> IO ()
execCodeAction fp r n expected = runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc fp "haskell"
-- Code actions aren't deferred - need to wait for compilation
_ <- count 2 waitForDiagnostics
ca <- getCANamed n <$> getCodeActions doc r
executeCodeAction ca
content <- getDocumentEdit doc
liftIO $ content `shouldBe` expected

34
test/functional/HieBiosSpec.hs Normal file
View File

@ -0,0 +1,34 @@
{-# LANGUAGE OverloadedStrings #-}
module HieBiosSpec where
import Control.Applicative.Combinators
import qualified Data.Text as T
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Messages
import System.FilePath ((</>))
import Test.Hspec
import TestUtils
spec :: Spec
-- Create an empty hie.yaml to trigger the parse error
spec = beforeAll_ (writeFile (hieBiosErrorPath </> "hie.yaml") "") $ do
describe "hie-bios" $ do
it "loads modules inside main-is" $ runSession hieCommand fullCaps "test/testdata/hieBiosMainIs" $ do
_ <- openDoc "Main.hs" "haskell"
_ <- count 2 waitForDiagnostics
return ()
it "reports errors in hie.yaml" $ runSession hieCommand fullCaps hieBiosErrorPath $ do
_ <- openDoc "Foo.hs" "haskell"
_ <- skipManyTill loggingNotification (satisfy isMessage)
return ()
where hieBiosErrorPath = "test/testdata/hieBiosError"
isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) =
"Couldn't parse hie.yaml" `T.isInfixOf` s
isMessage _ = False

2
test/functional/Main.hs
View File

@ -8,7 +8,7 @@ import TestUtils
main :: IO ()
main = do
setupStackFiles
setupBuildToolFiles
-- run a test session to warm up the cache to prevent timeouts in other tests
putStrLn "Warming up HIE cache..."
runSessionWithConfig (defaultConfig { messageTimeout = 120 }) hieCommand fullCaps "test/testdata" $

49
test/functional/ProgressSpec.hs
View File

@ -24,44 +24,53 @@ spec = describe "window/workDoneProgress" $ do
skipMany loggingNotification
-- Initial hlint notifications
_ <- publishDiagnosticsNotification
createRequest <- message :: Session WorkDoneProgressCreateRequest
liftIO $ do
createRequest ^. L.params `shouldBe` WorkDoneProgressCreateParams (ProgressNumericToken 0)
startNotification <- message :: Session WorkDoneProgressBeginNotification
liftIO $ do
startNotification ^. L.params . L.value . L.title `shouldBe` "Typechecking ApplyRefact2.hs"
-- Expect a multi cradle, since testdata project has multiple executables
startNotification ^. L.params . L.value . L.title `shouldBe` "Initializing Multi Component project"
startNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0)
doneNotification <- skipManyTill loggingNotification (message :: Session WorkDoneProgressEndNotification)
reportNotification <- message :: Session WorkDoneProgressReportNotification
liftIO $ do
reportNotification ^. L.params . L.value . L.message `shouldBe` Just "Main"
reportNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0)
-- may produce diagnostics
skipMany publishDiagnosticsNotification
doneNotification <- message :: Session WorkDoneProgressEndNotification
liftIO $ doneNotification ^. L.params . L.token `shouldBe` (ProgressNumericToken 0)
-- the ghc-mod diagnostics
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
-- Initial hlint notifications
_ <- publishDiagnosticsNotification
-- Test incrementing ids
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
-- hlint notifications
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
createRequest' <- skipManyTill loggingNotification (message :: Session WorkDoneProgressCreateRequest)
liftIO $ do
createRequest' ^. L.params `shouldBe` WorkDoneProgressCreateParams (ProgressNumericToken 1)
startNotification' <- message :: Session WorkDoneProgressBeginNotification
liftIO $ do
startNotification' ^. L.params . L.value . L.title `shouldBe` "Typechecking ApplyRefact2.hs"
startNotification' ^. L.params . L.value . L.title `shouldBe` "loading"
startNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1)
doneNotification' <- skipManyTill loggingNotification (message :: Session WorkDoneProgressEndNotification)
reportNotification' <- message :: Session WorkDoneProgressReportNotification
liftIO $ do
reportNotification' ^. L.params . L.value . L.message `shouldBe` Just "Main"
reportNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1)
doneNotification' <- message :: Session WorkDoneProgressEndNotification
liftIO $ doneNotification' ^. L.params . L.token `shouldBe` (ProgressNumericToken 1)
-- the ghc-mod diagnostics
const () <$> skipManyTill loggingNotification publishDiagnosticsNotification
-- Initial hlint notifications
_ <- publishDiagnosticsNotification
return ()
it "sends indefinite progress notifications with liquid" $
-- Testing that Liquid Haskell sends progress notifications
@ -70,14 +79,12 @@ spec = describe "window/workDoneProgress" $ do
skipMany loggingNotification
-- Initial hlint notifications
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
_ <- message :: Session WorkDoneProgressCreateRequest
_ <- message :: Session WorkDoneProgressCreateRequest
_ <- message :: Session WorkDoneProgressBeginNotification
_ <- message :: Session WorkDoneProgressReportNotification
_ <- message :: Session WorkDoneProgressEndNotification
-- the ghc-mod diagnostics
-- the hie-bios diagnostics
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
-- Enable liquid haskell plugin
@ -88,7 +95,9 @@ spec = describe "window/workDoneProgress" $ do
sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)
-- hlint notifications
_ <- skipManyTill loggingNotification publishDiagnosticsNotification
-- TODO: potential race between typechecking, e.g. context intialisation
-- TODO: and disabling hlint notifications
-- _ <- skipManyTill loggingNotification publishDiagnosticsNotification
let startPred (NotWorkDoneProgressBegin m) =
m ^. L.params . L.value . L.title == "Running Liquid Haskell on Evens.hs"

33
test/functional/RenameSpec.hs
View File

@ -1,23 +1,24 @@
{-# LANGUAGE OverloadedStrings #-}
module RenameSpec where
import Control.Monad.IO.Class
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Types
-- import Control.Monad.IO.Class
-- import Language.Haskell.LSP.Test
-- import Language.Haskell.LSP.Types
import Test.Hspec
import TestUtils
-- import TestUtils
spec :: Spec
spec = describe "rename" $
it "works" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "Rename.hs" "haskell"
rename doc (Position 3 1) "baz" -- foo :: Int -> Int
documentContents doc >>= liftIO . flip shouldBe expected
where
expected =
"main = do\n\
\ x <- return $ baz 42\n\
\ return (baz x)\n\
\baz :: Int -> Int\n\
\baz x = x + 1\n\
\bar = (+ 1) . baz\n"
it "works" $ pendingWith "removed because of HaRe"
-- runSession hieCommand fullCaps "test/testdata" $ do
-- doc <- openDoc "Rename.hs" "haskell"
-- rename doc (Position 3 1) "baz" -- foo :: Int -> Int
-- documentContents doc >>= liftIO . flip shouldBe expected
-- where
-- expected =
-- "main = do\n\
-- \ x <- return $ baz 42\n\
-- \ return (baz x)\n\
-- \baz :: Int -> Int\n\
-- \baz x = x + 1\n\
-- \bar = (+ 1) . baz\n"

25
test/functional/TypeDefinitionSpec.hs
View File

@ -74,18 +74,19 @@ spec = describe "type definitions" $ do
]
it "find type-definition of type def in component"
$ runSession hieCommand fullCaps "test/testdata/gototest"
$ do
doc <- openDoc "src/Lib2.hs" "haskell"
otherDoc <- openDoc "src/Lib.hs" "haskell"
closeDoc otherDoc
defs <- getTypeDefinitions doc (toPos (13, 20))
liftIO $ do
fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs"
defs
`shouldBe` [ Location (filePathToUri fp)
(Range (toPos (8, 1)) (toPos (8, 29)))
]
$ pendingWith "Finding symbols cross module is currently not supported"
-- $ runSession hieCommand fullCaps "test/testdata/gototest"
-- $ do
-- doc <- openDoc "src/Lib2.hs" "haskell"
-- otherDoc <- openDoc "src/Lib.hs" "haskell"
-- closeDoc otherDoc
-- defs <- getTypeDefinitions doc (toPos (13, 20))
-- liftIO $ do
-- fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs"
-- defs
-- `shouldBe` [ Location (filePathToUri fp)
-- (Range (toPos (8, 1)) (toPos (8, 29)))
-- ]
it "find definition of parameterized data type"
$ runSession hieCommand fullCaps "test/testdata/gototest"
$ do

18
test/plugin-dispatcher/Main.hs
View File

@ -12,7 +12,6 @@ import Haskell.Ide.Engine.Scheduler
import Haskell.Ide.Engine.Types
import Language.Haskell.LSP.Types
import TestUtils
import Test.Hspec
import Test.Hspec.Runner
@ -20,7 +19,7 @@ import Test.Hspec.Runner
main :: IO ()
main = do
setupStackFiles
setupBuildToolFiles
config <- getHspecFormattedConfig "plugin-dispatcher"
withFileLogging "plugin-dispatcher.log" $ hspecWith config newPluginSpec
@ -35,20 +34,21 @@ newPluginSpec = do
let defCallback = atomically . writeTChan outChan
delayedCallback = \r -> threadDelay 10000 >> defCallback r
let req0 = GReq 0 Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) $ return $ IdeResultOk $ T.pack "text0"
req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) defCallback $ return $ IdeResultOk $ T.pack "text1"
req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) delayedCallback $ return $ IdeResultOk $ T.pack "text2"
req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing defCallback $ return $ IdeResultOk $ T.pack "text3"
req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) defCallback $ return $ IdeResultOk $ T.pack "text4"
let req0 = GReq 0 "0" Nothing Nothing (Just $ IdInt 0) (\_ -> return () :: IO ()) "none" $ return $ IdeResultOk $ T.pack "text0"
req1 = GReq 1 "1" Nothing Nothing (Just $ IdInt 1) defCallback "none" $ return $ IdeResultOk $ T.pack "text1"
req2 = GReq 2 "2" Nothing Nothing (Just $ IdInt 2) delayedCallback "none" $ return $ IdeResultOk $ T.pack "text2"
req3 = GReq 3 "3" Nothing (Just (filePathToUri "test", 2)) Nothing defCallback "none" $ return $ IdeResultOk $ T.pack "text3"
req4 = GReq 4 "4" Nothing Nothing (Just $ IdInt 3) defCallback "none" $ return $ IdeResultOk $ T.pack "text4"
let makeReq = sendRequest scheduler Nothing
let makeReq = sendRequest scheduler
pid <- forkIO $ runScheduler scheduler
(\_ _ _ -> return ())
(\f x -> f x)
def
sendRequest scheduler (Just (filePathToUri "test", 3)) req0
updateDocument scheduler (filePathToUri "test") 3
sendRequest scheduler req0
makeReq req1
makeReq req2
cancelRequest scheduler (IdInt 2)

2
test/testdata/FuncTestFail.hs vendored
View File

@ -1,2 +1,2 @@
main :: IO Int
main = return "yow"
main = return "yow

10
test/testdata/HaReGA1/HaReGA1.cabal vendored Normal file
View File

@ -0,0 +1,10 @@
name: HaReGA1
version: 0.1.0.0
cabal-version: >=2.0
build-type: Simple
executable harega
build-depends: base, parsec
main-is: HaReGA1.hs
default-language: Haskell2010

0
test/testdata/HaReGA1.hs → test/testdata/HaReGA1/HaReGA1.hs vendored
View File

0
test/testdata/wrapper/8.2.1/cabal.project → test/testdata/HaReGA1/cabal.project vendored
View File

37
test/testdata/addPackageTest/hpack-exe/asdf.cabal vendored Normal file
View File

@ -0,0 +1,37 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.32.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 69241e1f4f912f034502d225d2017f035c38062080733108c11cd3d111cb9007
name: asdf
version: 0.1.0.0
description: Please see the README on GitHub at <https://github.com/githubuser/asdf#readme>
homepage: https://github.com/githubuser/asdf#readme
bug-reports: https://github.com/githubuser/asdf/issues
author: Author name here
maintainer: example@example.com
copyright: 2018 Author name here
license: BSD3
build-type: Simple
extra-source-files:
README.md
ChangeLog.md
source-repository head
type: git
location: https://github.com/githubuser/asdf
executable asdf-exe
main-is: Main.hs
other-modules:
Asdf
Paths_asdf
hs-source-dirs:
app
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
default-language: Haskell2010

4
test/testdata/addPackageTest/hpack-exe/package.yaml vendored
View File

@ -29,6 +29,4 @@ executables:
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- asdf
- -with-rtsopts=-N

9
test/testdata/gototest/test.cabal → test/testdata/addPragmas/test.cabal vendored
View File

@ -10,8 +10,9 @@ category: Web
build-type: Simple
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Lib, Lib2
executable p
main-is: NeedsPragmas.hs
hs-source-dirs: .
build-depends: base >= 4.7 && < 5
default-language: Haskell2010
default-language: Haskell2010
ghc-options: -Wall

10
test/testdata/completion/completions.cabal vendored Normal file
View File

@ -0,0 +1,10 @@
name: completions
version: 0.1.0.0
cabal-version: >= 2.0
build-type: Simple
executable compl-exe
other-modules: DupRecFields, Context
main-is: Completion.hs
default-language: Haskell2010
build-depends: base

3
test/testdata/gototest/cabal.project vendored Normal file
View File

@ -0,0 +1,3 @@
packages: .
write-ghc-environment-files: never

24
test/testdata/gototest/gototest.cabal vendored Normal file
View File

@ -0,0 +1,24 @@
name: gototest
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
author: Author name here
maintainer: example@example.com
copyright: 2017 Author name here
category: Web
build-type: Simple
cabal-version: >=1.10
executable gototest-exec
hs-source-dirs: app
main-is: Main.hs
other-modules:
build-depends: base >= 4.7 && < 5, gototest
default-language: Haskell2010
library
hs-source-dirs: src
exposed-modules: Lib, Lib2
build-depends: base >= 4.7 && < 5
default-language: Haskell2010

2
test/testdata/gototest/src/Lib.hs vendored
View File

@ -1,5 +1,5 @@
module Lib
where
someFunc :: IO ()

1
test/testdata/hieBiosError/Foo.hs vendored Normal file
View File

@ -0,0 +1 @@
main = putStrLn "hey"

4
test/testdata/hieBiosMainIs/Main.hs vendored Normal file
View File

@ -0,0 +1,4 @@
module Main where
main :: IO ()
main = putStrLn "Hello, Haskell!"

2
test/testdata/hieBiosMainIs/Setup.hs vendored Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

8
test/testdata/hieBiosMainIs/hieBiosMainIs.cabal vendored Normal file
View File

@ -0,0 +1,8 @@
cabal-version: >=1.10
name: hieBiosMainIs
version: 0.1.0.0
build-type: Simple
executable hieBiosMainIs
main-is: Main.hs
build-depends: base >=4.12 && <4.13
default-language: Haskell2010

1
test/testdata/redundantImportTest/src/CodeActionRedundant.hs vendored
View File

@ -1,3 +1,4 @@
module CodeActionRedundant where
import Data.List
main :: IO ()
main = putStrLn "hello"

3
test/testdata/redundantImportTest/test.cabal vendored
View File

@ -11,7 +11,8 @@ build-type: Simple
cabal-version: >=1.10
library
exposed-modules: CodeActionRedundant, MultipleImports
hs-source-dirs: src
build-depends: base >= 4.7 && < 5
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -Wall -fwarn-unused-imports

26
test/testdata/testdata.cabal vendored
View File

@ -8,6 +8,32 @@ executable applyrefact
main-is: ApplyRefact.hs
default-language: Haskell2010
executable applyrefact2
build-depends: base
main-is: ApplyRefact2.hs
default-language: Haskell2010
executable codeactionrename
build-depends: base
main-is: CodeActionRename.hs
default-language: Haskell2010
executable hover
build-depends: base
main-is: Hover.hs
default-language: Haskell2010
executable symbols
build-depends: base
main-is: Symbols.hs
default-language: Haskell2010
executable applyrefact2
build-depends: base
main-is: ApplyRefact2.hs
default-language: Haskell2010
executable hlintpragma
build-depends: base
main-is: HlintPragma.hs

1
test/testdata/wErrorTest/test.cabal vendored
View File

@ -11,6 +11,7 @@ build-type: Simple
cabal-version: >=1.10
library
exposed-modules: WError
hs-source-dirs: src
build-depends: base >= 4.7 && < 5
default-language: Haskell2010

3
test/testdata/wrapper/8.2.1/hie.yaml vendored Normal file
View File

@ -0,0 +1,3 @@
# TODO: generate this in test suite
cradle:
stack:

1
test/testdata/wrapper/lts-11.14/cabal.project vendored
View File

@ -1 +0,0 @@
packages: .

3
test/testdata/wrapper/lts-11.14/hie.yaml vendored Normal file
View File

@ -0,0 +1,3 @@
# TODO: generate this in test suite
cradle:
stack:

2
test/unit/CodeActionsSpec.hs
View File

@ -4,7 +4,7 @@ module CodeActionsSpec where
import Test.Hspec
import qualified Data.Text.IO as T
import Haskell.Ide.Engine.Plugin.HsImport
import Haskell.Ide.Engine.Plugin.GhcMod
import Haskell.Ide.Engine.Plugin.Generic hiding (Import)
import Haskell.Ide.Engine.Plugin.Package
main :: IO ()

145
test/unit/GhcModPluginSpec.hs → test/unit/GenericPluginSpec.hs
View File

@ -1,18 +1,17 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module GhcModPluginSpec where
module GenericPluginSpec where
import Control.Exception
import qualified Data.HashMap.Strict as H
import qualified Data.Map as Map
import qualified Data.Set as S
import qualified Data.Text as T
import Haskell.Ide.Engine.Ghc
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.Plugin.GhcMod
import Haskell.Ide.Engine.Plugin.Generic
import Haskell.Ide.Engine.Plugin.Bios
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.Support.HieExtras
import Language.Haskell.LSP.Types (TextEdit (..), toNormalizedUri)
import Language.Haskell.LSP.Types (toNormalizedUri)
import System.Directory
import TestUtils
@ -30,7 +29,7 @@ spec = do
-- ---------------------------------------------------------------------
testPlugins :: IdePlugins
testPlugins = pluginDescToIdePlugins [ghcmodDescriptor "ghcmod"]
testPlugins = pluginDescToIdePlugins [biosDescriptor "bios", genericDescriptor "generic" ]
-- ---------------------------------------------------------------------
@ -53,11 +52,11 @@ ghcmodSpec =
(toPos (4,8)))
(Just DsError)
Nothing
(Just "ghcmod")
(Just "bios")
"Variable not in scope: x"
Nothing
testCommand testPlugins act "ghcmod" "check" arg res
testCommand testPlugins act "bios" "check" arg res
-- ---------------------------------
@ -72,7 +71,7 @@ ghcmodSpec =
-- #else
-- res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULWhy not:\NUL return (3 + x)\n")
-- #endif
-- testCommand testPlugins act "ghcmod" "lint" arg res
-- testCommand testPlugins act "bios" "lint" arg res
-- ---------------------------------
@ -83,7 +82,7 @@ ghcmodSpec =
-- arg = IP uri "main"
-- res = IdeResultOk "main :: IO () \t-- Defined at HaReRename.hs:2:1\n"
-- -- ghc-mod tries to load the test file in the context of the hie project if we do not cd first.
-- testCommand testPlugins act "ghcmod" "info" arg res
-- testCommand testPlugins act "bios" "info" arg res
-- ----------------------------------------------------------------------------
@ -99,7 +98,7 @@ ghcmodSpec =
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "HaReRename.hs"
@ -112,7 +111,7 @@ ghcmodSpec =
[ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()")
, (Range (toPos (2, 1)) (toPos (2,24)), "IO ()")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, no type at location" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "HaReRename.hs"
@ -122,7 +121,7 @@ ghcmodSpec =
liftToGhc $ newTypeCmd (toPos (1,1)) uri
arg = TP False uri (toPos (1,1))
res = IdeResultOk []
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -135,7 +134,7 @@ ghcmodSpec =
[ (Range (toPos (6, 16)) (toPos (6,17)), "Int")
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, sum type pattern match, just" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -149,7 +148,7 @@ ghcmodSpec =
, (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int")
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, sum type pattern match, just value" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -164,7 +163,7 @@ ghcmodSpec =
, (Range (toPos (6, 5)) (toPos (6, 13)), "Maybe Int")
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, sum type pattern match, nothing" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -177,7 +176,7 @@ ghcmodSpec =
[ (Range (toPos (7, 5)) (toPos (7, 12)), "Maybe Int")
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, sum type pattern match, nothing, literal" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -190,7 +189,7 @@ ghcmodSpec =
[ (Range (toPos (7, 15)) (toPos (7, 16)), "Int")
, (Range (toPos (6, 1)) (toPos (7, 16)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -203,7 +202,7 @@ ghcmodSpec =
[ (Range (toPos (10, 5)) (toPos (10, 6)), "Maybe Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, case expr" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -217,7 +216,7 @@ ghcmodSpec =
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, case expr match, just" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -231,7 +230,7 @@ ghcmodSpec =
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, case expr match, just value" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -246,7 +245,7 @@ ghcmodSpec =
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -260,7 +259,7 @@ ghcmodSpec =
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, case expr match, nothing" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -274,7 +273,7 @@ ghcmodSpec =
, (Range (toPos (10, 9)) (toPos (12, 17)), "Maybe Int -> Int")
, (Range (toPos (10, 1)) (toPos (12, 17)), "Maybe Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, do bind expr result " $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -287,7 +286,7 @@ ghcmodSpec =
[ (Range (toPos (16, 5)) (toPos (16, 6)), "Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -300,7 +299,7 @@ ghcmodSpec =
[ (Range (toPos (16, 10)) (toPos (16, 11)), "Maybe Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding function, return func" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -314,7 +313,7 @@ ghcmodSpec =
, (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding function, return param" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -328,7 +327,7 @@ ghcmodSpec =
, (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding function, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -341,7 +340,7 @@ ghcmodSpec =
[ (Range (toPos (17, 9)) (toPos (17, 28)), "Maybe Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -354,7 +353,7 @@ ghcmodSpec =
[ (Range (toPos (18, 10)) (toPos (18, 11)), "Maybe Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding function, do expr bind for local func" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -367,7 +366,7 @@ ghcmodSpec =
[ (Range (toPos (18, 5)) (toPos (18, 6)), "Int")
, (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -379,7 +378,7 @@ ghcmodSpec =
res = IdeResultOk
[ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -392,7 +391,7 @@ ghcmodSpec =
[ (Range (toPos (22, 10)) (toPos (22, 11)), "a -> a")
, (Range (toPos (22, 1)) (toPos (22, 19)), "(a -> a) -> a -> a")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, function composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -406,7 +405,7 @@ ghcmodSpec =
, (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c")
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding, function composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -419,7 +418,7 @@ ghcmodSpec =
[ (Range (toPos (25, 20)) (toPos (25, 29)), "a -> c")
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -432,7 +431,7 @@ ghcmodSpec =
[ (Range (toPos (25, 33)) (toPos (25, 34)), "a -> c")
, (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, function type composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -444,7 +443,7 @@ ghcmodSpec =
res = IdeResultOk
[ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -457,7 +456,7 @@ ghcmodSpec =
[ (Range (toPos (28, 25)) (toPos (28, 28)), "(a -> b) -> IO a -> IO b")
, (Range (toPos (28, 1)) (toPos (28, 35)), "(a -> b) -> IO a -> IO b")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, constructor" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -469,7 +468,7 @@ ghcmodSpec =
res = IdeResultOk
[ -- (Range (toPos (31, 7)) (toPos (31, 12)), "Int -> Test")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, deriving clause Show type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -484,7 +483,7 @@ ghcmodSpec =
, (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String")
, (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
it "runs the type command, deriving clause Eq type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
@ -498,7 +497,7 @@ ghcmodSpec =
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
-- ----------------------------------------------------------------------------
it "runs the type command with an absolute path from another folder, correct params" $ do
@ -517,39 +516,39 @@ ghcmodSpec =
[(Range (toPos (5,9)) (toPos (5,10)), "Int")
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
testCommand testPlugins act "generic" "type" arg res
-- ---------------------------------
it "runs the casesplit command" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "GhcModCaseSplit.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
splitCaseCmd' uri (toPos (5,5))
arg = HP uri (toPos (5,5))
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri
$ List [TextEdit (Range (Position 4 0) (Position 4 10))
"foo Nothing = ()\nfoo (Just x) = ()"])
Nothing
testCommand testPlugins act "ghcmod" "casesplit" arg res
-- it "runs the casesplit command" $ withCurrentDirectory "./test/testdata" $ do
-- fp <- makeAbsolute "GhcModCaseSplit.hs"
-- let uri = filePathToUri fp
-- act = do
-- _ <- setTypecheckedModule uri
-- splitCaseCmd' uri (toPos (5,5))
-- arg = HP uri (toPos (5,5))
-- res = IdeResultOk $ WorkspaceEdit
-- (Just $ H.singleton uri
-- $ List [TextEdit (Range (Position 4 0) (Position 4 10))
-- "foo Nothing = ()\nfoo (Just x) = ()"])
-- Nothing
-- testCommand testPlugins act "bios" "casesplit" arg res
it "runs the casesplit command with an absolute path from another folder, correct params" $ do
fp <- makeAbsolute "./test/testdata/GhcModCaseSplit.hs"
cd <- getCurrentDirectory
cd2 <- getHomeDirectory
bracket (setCurrentDirectory cd2)
(\_-> setCurrentDirectory cd)
$ \_-> do
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
splitCaseCmd' uri (toPos (5,5))
arg = HP uri (toPos (5,5))
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri
$ List [TextEdit (Range (Position 4 0) (Position 4 10))
"foo Nothing = ()\nfoo (Just x) = ()"])
Nothing
testCommand testPlugins act "ghcmod" "casesplit" arg res
-- it "runs the casesplit command with an absolute path from another folder, correct params" $ do
-- fp <- makeAbsolute "./test/testdata/GhcModCaseSplit.hs"
-- cd <- getCurrentDirectory
-- cd2 <- getHomeDirectory
-- bracket (setCurrentDirectory cd2)
-- (\_-> setCurrentDirectory cd)
-- $ \_-> do
-- let uri = filePathToUri fp
-- act = do
-- _ <- setTypecheckedModule uri
-- splitCaseCmd' uri (toPos (5,5))
-- arg = HP uri (toPos (5,5))
-- res = IdeResultOk $ WorkspaceEdit
-- (Just $ H.singleton uri
-- $ List [TextEdit (Range (Position 4 0) (Position 4 10))
-- "foo Nothing = ()\nfoo (Just x) = ()"])
-- Nothing
-- testCommand testPlugins act "bios" "casesplit" arg res

297
test/unit/HaRePluginSpec.hs
View File

@ -1,297 +0,0 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module HaRePluginSpec where
import Control.Monad.Trans.Free
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Map as M
import qualified Data.HashMap.Strict as H
import Haskell.Ide.Engine.Ghc
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.PluginUtils
import Haskell.Ide.Engine.Plugin.HaRe
import Haskell.Ide.Engine.Support.HieExtras
import Language.Haskell.LSP.Types ( Location(..)
, TextEdit(..)
)
import System.Directory
import System.FilePath
import TestUtils
import Test.Hspec
-- ---------------------------------------------------------------------
{-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
{-# ANN module ("hlint: ignore Redundant do" :: String) #-}
-- ---------------------------------------------------------------------
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "hare plugin" hareSpec
-- ---------------------------------------------------------------------
testPlugins :: IdePlugins
testPlugins = pluginDescToIdePlugins [hareDescriptor "hare"]
dispatchRequestPGoto :: IdeGhcM a -> IO a
dispatchRequestPGoto =
withCurrentDirectory "./test/testdata/gototest"
. runIGM testPlugins
-- ---------------------------------------------------------------------
hareSpec :: Spec
hareSpec = do
describe "hare plugin commands(old plugin api)" $ do
cwd <- runIO getCurrentDirectory
-- ---------------------------------
it "renames" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
act = renameCmd' uri (toPos (5,1)) "foolong"
arg = HPT uri (toPos (5,1)) "foolong"
textEdits = List [TextEdit (Range (Position 3 0) (Position 4 13)) "foolong :: Int -> Int\nfoolong x = x + 3"]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "rename" arg res
-- ---------------------------------
it "returns an error for invalid rename" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
act = renameCmd' uri (toPos (15,1)) "foolong"
arg = HPT uri (toPos (15,1)) "foolong"
res = IdeResultFail
IdeError { ideCode = PluginError
, ideMessage = "rename: \"Invalid cursor position!\"", ideInfo = Null}
testCommand testPlugins act "hare" "rename" arg res
-- ---------------------------------
it "demotes" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReDemote.hs"
act = demoteCmd' uri (toPos (6,1))
arg = HP uri (toPos (6,1))
textEdits = List [TextEdit (Range (Position 4 0) (Position 5 5)) " where\n y = 7"]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "demote" arg res
-- ---------------------------------
it "duplicates a definition" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReRename.hs"
act = dupdefCmd' uri (toPos (5,1)) "foonew"
arg = HPT uri (toPos (5,1)) "foonew"
textEdits = List [TextEdit (Range (Position 6 0) (Position 6 0)) "foonew :: Int -> Int\nfoonew x = x + 3\n\n"]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "dupdef" arg res
-- ---------------------------------
it "converts if to case" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReCase.hs"
act = iftocaseCmd' uri (Range (toPos (5,9))
(toPos (9,12)))
arg = HR uri (toPos (5,9)) (toPos (9,12))
textEdits = List [TextEdit (Range (Position 4 0) (Position 8 11))
"foo x = case odd x of\n True ->\n x + 3\n False ->\n x"]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "iftocase" arg res
-- ---------------------------------
it "lifts one level" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReMoveDef.hs"
act = liftonelevelCmd' uri (toPos (6,5))
arg = HP uri (toPos (6,5))
textEdits = List [ TextEdit (Range (Position 6 0) (Position 6 0)) "y = 4\n\n"
, TextEdit (Range (Position 4 0) (Position 6 0)) ""]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "liftonelevel" arg res
-- ---------------------------------
it "lifts to top level" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReMoveDef.hs"
act = lifttotoplevelCmd' uri (toPos (12,9))
arg = HP uri (toPos (12,9))
textEdits = List [ TextEdit (Range (Position 13 0) (Position 13 0)) "\n"
, TextEdit (Range (Position 12 0) (Position 12 0)) "z = 7\n"
, TextEdit (Range (Position 10 0) (Position 12 0)) ""
]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "lifttotoplevel" arg res
-- ---------------------------------
it "deletes a definition" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/FuncTest.hs"
act = deleteDefCmd' uri (toPos (6,1))
arg = HP uri (toPos (6,1))
textEdits = List [TextEdit (Range (Position 4 0) (Position 7 0)) ""]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "deletedef" arg res
-- ---------------------------------
it "generalises an applicative" $ withCurrentDirectory "test/testdata" $ do
let uri = filePathToUri $ cwd </> "test/testdata/HaReGA1.hs"
act = genApplicativeCommand' uri (toPos (4,1))
arg = HP uri (toPos (4,1))
textEdits = List [TextEdit (Range (Position 4 0) (Position 8 12))
"parseStr = char '\"' *> (many1 (noneOf \"\\\"\")) <* char '\"'"]
res = IdeResultOk $ WorkspaceEdit
(Just $ H.singleton uri textEdits)
Nothing
testCommand testPlugins act "hare" "genapplicative" arg res
-- ---------------------------------
describe "Additional GHC API commands" $ do
cwd <- runIO getCurrentDirectory
it "finds definition across components" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/app/Main.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findDef u (toPos (7,8))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (6,1)) (toPos (6,9)))]
let req2 = liftToGhc $ TestDeferM $ findDef u (toPos (7,20))
r2 <- dispatchRequestPGoto $ lreq >> req2
r2 `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
(Range (toPos (5,1)) (toPos (5,2)))]
it "finds definition in the same component" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findDef u (toPos (6,5))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (6,1)) (toPos (6,9)))]
it "finds local definitions" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findDef u (toPos (7,11))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
(Range (toPos (10,9)) (toPos (10,10)))]
let req2 = liftToGhc $ TestDeferM $ findDef u (toPos (10,13))
r2 <- dispatchRequestPGoto $ lreq >> req2
r2 `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
(Range (toPos (9,9)) (toPos (9,10)))]
it "finds local definition of record variable" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (11, 23))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (8, 1)) (toPos (8, 29)))
]
it "finds local definition of newtype variable" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (16, 21))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (13, 1)) (toPos (13, 30)))
]
it "finds local definition of sum type variable" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (21, 13))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (18, 1)) (toPos (18, 26)))
]
it "finds local definition of sum type contructor" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (24, 7))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (18, 1)) (toPos (18, 26)))
]
it "can not find non-local definition of type def" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (30, 17))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk []
it "find local definition of type def" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (35, 16))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (18, 1)) (toPos (18, 26)))
]
it "find type-definition of type def in component" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (13, 20))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (8, 1)) (toPos (8, 29)))
]
it "find definition of parameterized data type" $ do
let u = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
lreq = setTypecheckedModule u
req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (40, 19))
r <- dispatchRequestPGoto $ lreq >> req
r `shouldBe` IdeResultOk
[ Location
(filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
(Range (toPos (37, 1)) (toPos (37, 31)))
]
-- ---------------------------------
newtype TestDeferM a = TestDeferM (IdeDeferM a) deriving (Functor, Applicative, Monad)
instance LiftsToGhc TestDeferM where
liftToGhc (TestDeferM (FreeT f)) = do
x <- liftToGhc f
case x of
Pure a -> return a
Free (Defer fp cb) -> do
fp' <- liftIO $ canonicalizePath fp
muc <- fmap (M.lookup fp' . uriCaches) getModuleCache
case muc of
Just uc -> liftToGhc $ TestDeferM $ cb uc
Nothing -> error "No cache to lift IdeDeferM to IdeGhcM"

Some files were not shown because too many files have changed in this diff Show More