haskell/haskell-ide-engine
1
1
Fork 0
mirror of https://github.com/haskell/haskell-ide-engine.git synced 2024-09-11 11:05:30 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' of https://github.com/haskell/haskell-ide-engine into hie-bios-wz1000

Browse Source
This commit is contained in:
Zubin Duggal 2019-07-15 17:32:26 +05:30
commit 5ab587cfa2
No known key found for this signature in database
GPG Key ID: 7CCFC277A14C97A7
91 changed files with 2783 additions and 1212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
.azure/linux-installhs-stack.yml Normal file
View File

@ -0,0 +1,32 @@
jobs:
- job: Linux_installhs_Stack
timeoutInMinutes: 0
pool:
vmImage: ubuntu-16.04
strategy:
matrix:
shake:
YAML_FILE: install/shake.yaml
steps:
- bash: |
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root
mkdir -p ~/.local/bin
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | \
tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
displayName: Install stack
- bash: |
source .azure/linux.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/linux.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/linux.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie-install`
- bash: |
source .azure/linux.bashrc
stack install.hs help
displayName: Run help of `instal.hs`

68
.azure/linux-stack.yml Normal file
View File

@ -0,0 +1,68 @@
jobs:
- job: Linux_Stack
timeoutInMinutes: 0
pool:
vmImage: ubuntu-16.04
strategy:
matrix:
stack-def:
YAML_FILE: stack.yaml
stack-8.6.5:
YAML_FILE: stack-8.6.5.yaml
stack-8.6.4:
YAML_FILE: stack-8.6.4.yaml
stack-8.6.3:
YAML_FILE: stack-8.6.3.yaml
stack-8.6.2:
YAML_FILE: stack-8.6.2.yaml
stack-8.6.1:
YAML_FILE: stack-8.6.1.yaml
stack-8.4.4:
YAML_FILE: stack-8.4.4.yaml
stack-8.4.3:
YAML_FILE: stack-8.4.3.yaml
stack-8.4.2:
YAML_FILE: stack-8.4.2.yaml
stack-8.2.2:
YAML_FILE: stack-8.2.2.yaml
steps:
- bash: |
git submodule sync
git submodule update --init
displayName: Sync submodules
- bash: |
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root
mkdir -p ~/.local/bin
curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | \
tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
displayName: Install stack
- bash: |
source .azure/linux.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/linux.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/linux.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie`
- bash: |
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
sudo apt install z3
displayName: "Install Runtime Test-Dependencies: z3"
- bash: |
source .azure/linux.bashrc
stack install --resolver=lts-11.18 liquid-fixpoint-0.7.0.7 dotgen-0.4.2 fgl-visualize-0.1.0.1 located-base-0.1.1.1 liquidhaskell-0.8.2.4
displayName: "Install Runtime Test-Dependencies: liquidhaskell"
# - bash: |
# source .azure/linux.bashrc
# stack test --stack-yaml $(YAML_FILE)
# displayName: Run Test

1
.azure/linux.bashrc Normal file
View File

@ -0,0 +1 @@
export PATH=$HOME/.local/bin:$PATH

32
.azure/macos-installhs-stack.yml Normal file
View File

@ -0,0 +1,32 @@
jobs:
- job: MacOs_installhs_Stack
timeoutInMinutes: 0
pool:
vmImage: macOS-10.13
strategy:
matrix:
shake:
YAML_FILE: install/shake.yaml
steps:
- bash: |
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root
mkdir -p ~/.local/bin
curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | \
tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
displayName: Install stack
- bash: |
source .azure/macos.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/macos.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/macos.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie-install`
- bash: |
source .azure/macos.bashrc
stack install.hs help
displayName: Run help of `instal.hs`

65
.azure/macos-stack.yml Normal file
View File

@ -0,0 +1,65 @@
jobs:
- job: MacOs_Stack
timeoutInMinutes: 0
pool:
vmImage: macOS-10.13
strategy:
matrix:
stack-def:
YAML_FILE: stack.yaml
stack-8.6.5:
YAML_FILE: stack-8.6.5.yaml
stack-8.6.4:
YAML_FILE: stack-8.6.4.yaml
stack-8.6.3:
YAML_FILE: stack-8.6.3.yaml
stack-8.4.4:
YAML_FILE: stack-8.4.4.yaml
stack-8.4.3:
YAML_FILE: stack-8.4.3.yaml
stack-8.4.2:
YAML_FILE: stack-8.4.2.yaml
stack-8.2.2:
YAML_FILE: stack-8.2.2.yaml
steps:
- bash: |
git submodule sync
git submodule update --init
displayName: Sync submodules
- bash: |
export STACK_ROOT="$(Build.SourcesDirectory)"/.stack-root
mkdir -p ~/.local/bin
curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | \
tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
displayName: Install stack
- bash: |
source .azure/macos.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/macos.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/macos.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie`
- bash: |
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)"
brew update
brew install z3
displayName: "Install Runtime Test-Dependencies: z3"
- bash: |
source .azure/macos.bashrc
stack install --resolver=lts-11.18 liquid-fixpoint-0.7.0.7 dotgen-0.4.2 fgl-visualize-0.1.0.1 located-base-0.1.1.1 liquidhaskell-0.8.2.4
displayName: "Install Runtime Test-Dependencies: liquidhaskell"
# - bash: |
# source .azure/macos.bashrc
# stack test --stack-yaml $(YAML_FILE)
# displayName: Run Test

1
.azure/macos.bashrc Normal file
View File

@ -0,0 +1 @@
export PATH=$HOME/.local/bin:$PATH

37
.azure/windows-installhs-cabal.yml Normal file
View File

@ -0,0 +1,37 @@
jobs:
- job: Windows_installhs_Cabal
timeoutInMinutes: 0
pool:
vmImage: windows-2019
variables:
YAML_FILE: install/shake.yaml
PROJECT_FILE: install/shake.project
steps:
- bash: |
curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
unzip -o /usr/bin/stack.zip -d /usr/bin/
displayName: Install stack
- bash: |
source .azure/windows.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/windows.bashrc
stack install cabal-install --stack-yaml $(YAML_FILE)
displayName: Install `cabal-install`
- bash: |
source .azure/windows.bashrc
cabal update
displayName: update cabal
# - bash: |
# source .azure/windows.bashrc
# stack --stack-yaml $(YAML_FILE) build --only-dependencies
# displayName: Build dependencies
- bash: |
source .azure/windows.bashrc
cabal v2-build hie-install -w $(stack path --stack-yaml $(YAML_FILE) --compiler-exe) --project-file $(PROJECT_FILE)
displayName: Build `hie-install`
- bash: |
source .azure/windows.bashrc
cabal v2-run install.hs -w $(stack path --stack-yaml $(YAML_FILE) --compiler-exe) --project-file $(PROJECT_FILE) help
displayName: Run help of `install.hs`

30
.azure/windows-installhs-stack.yml Normal file
View File

@ -0,0 +1,30 @@
jobs:
- job: Windows_installhs_Stack
timeoutInMinutes: 0
pool:
vmImage: windows-2019
strategy:
matrix:
shake:
YAML_FILE: install/shake.yaml
steps:
- bash: |
curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
unzip -o /usr/bin/stack.zip -d /usr/bin/
displayName: Install stack
- bash: |
source .azure/windows.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/windows.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/windows.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie-install`
- bash: |
source .azure/windows.bashrc
stack install.hs help
displayName: Run help of `instal.hs`

67
.azure/windows-stack.yml Normal file
View File

@ -0,0 +1,67 @@
jobs:
- job: Windows_Stack
timeoutInMinutes: 0
pool:
vmImage: windows-2019
strategy:
matrix:
stack-def:
YAML_FILE: stack.yaml
stack-8.6.5:
YAML_FILE: stack-8.6.5.yaml
stack-8.6.4:
YAML_FILE: stack-8.6.4.yaml
stack-8.6.2:
YAML_FILE: stack-8.6.2.yaml
stack-8.6.1:
YAML_FILE: stack-8.6.1.yaml
stack-8.4.4:
YAML_FILE: stack-8.4.4.yaml
stack-8.4.3:
YAML_FILE: stack-8.4.3.yaml
stack-8.4.2:
YAML_FILE: stack-8.4.2.yaml
stack-8.2.2:
YAML_FILE: stack-8.2.2.yaml
steps:
- bash: |
git submodule sync
git submodule update --init
displayName: Sync submodules
- bash: |
curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
unzip -o /usr/bin/stack.zip -d /usr/bin/
displayName: Install stack
- bash: |
source .azure/windows.bashrc
stack setup --stack-yaml $(YAML_FILE)
displayName: Install GHC
- bash: |
source .azure/windows.bashrc
stack --stack-yaml $(YAML_FILE) --install-ghc build --only-dependencies
displayName: Build dependencies
- bash: |
source .azure/windows.bashrc
stack build --stack-yaml $(YAML_FILE)
displayName: Build `hie`
- bash: |
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)
mkdir -p /usr/local
curl -L https://github.com/Z3Prover/z3/releases/download/Z3-4.8.5/z3-4.8.5-x64-win.zip -o /usr/local/z3.zip
unzip -o /usr/local/z3.zip -d /usr/local/
displayName: "Install Runtime Test-Dependencies: z3"
- bash: |
source .azure/windows.bashrc
stack install --resolver=lts-11.18 liquid-fixpoint-0.7.0.7 dotgen-0.4.2 fgl-visualize-0.1.0.1 located-base-0.1.1.1 liquidhaskell-0.8.2.4
liquid -v
displayName: "Install Runtime Test-Dependencies: liquidhaskell"
# - bash: |
# source .azure/windows.bashrc
# stack test --stack-yaml $(YAML_FILE) :unit-test
# displayName: Run Test

4
.azure/windows.bashrc Normal file
View File

@ -0,0 +1,4 @@
export STACK_ROOT="C:\\sr"
export LOCAL_BIN_PATH=$(cygpath $APPDATA\\local\\bin)
export Z3_BIN_PATH=/usr/local/z3-4.8.5-x64-win/bin
export PATH=$Z3_BIN_PATH:$LOCAL_BIN_PATH:$PATH

1
.circleci/config.yml
View File

@ -195,7 +195,6 @@ workflows:
version: 2
multiple-ghcs:
jobs:
- ghc-8.2.1
- ghc-8.2.2
- ghc-8.4.2
- ghc-8.4.3

6
.gitignore vendored
View File

@ -69,4 +69,8 @@ test-results/
.vscode
# shake build information
_build/
_build/
# stack 2.1 stack.yaml lock files
stack*.yaml.lock
shake.yaml.lock

4
.gitmodules vendored
View File

@ -15,10 +15,6 @@
# url = https://github.com/bubba/HaRe.git
url = https://github.com/alanz/HaRe.git
[submodule "submodules/brittany"]
path = submodules/brittany
url = https://github.com/lspitzner/brittany.git
[submodule "submodules/cabal-helper"]
path = submodules/cabal-helper
# url = https://github.com/arbor/cabal-helper.git

17
.travis.yml
View File

@ -54,10 +54,6 @@ jobs:
env: GHC_VER="8.2.2"
script: *setup
- stage: setup
env: GHC_VER="8.2.1"
script: *setup
- stage: dependencies
env: GHC_VER="8.4.4"
script: &dependencies
@ -75,10 +71,6 @@ jobs:
env: GHC_VER="8.2.2"
script: *dependencies
- stage: dependencies
env: GHC_VER="8.2.1"
script: *dependencies
- stage: test
env: GHC_VER="8.4.4"
script: &test
@ -96,10 +88,6 @@ jobs:
env: GHC_VER="8.2.2"
script: *test
- stage: test
env: GHC_VER="8.2.1"
script: *test
- stage: deploy
env: GHC_VER="8.4.4"
script: &deploy
@ -135,8 +123,3 @@ jobs:
env: GHC_VER="8.2.2"
script: *deploy
deploy: *upload
- stage: deploy
env: GHC_VER="8.2.1"
script: *deploy
deploy: *upload

162
Changelog.md
View File

@ -1,3 +1,165 @@
# 0.11.0.0
- Bump resolvers. `lts-13.27` for GHC 8.6.5, `nightly-2019-07-07` for
nightly build, rest are unchanged.
([#1319 ](https://github.com/haskell/haskell-ide-engine/pull/1319),by @alanz)
([#1316 ](https://github.com/haskell/haskell-ide-engine/pull/1316), by @lorenzo)
- Clear out pattern matching and error message of executeCodeActionByName
([#1317 ](https://github.com/haskell/haskell-ide-engine/pull/1317), by @jneira)
- Upgrade to haskell-lsp 0.15
([#1316 ](https://github.com/haskell/haskell-ide-engine/pull/1316), by @lorenzo)
- Update Arch Linux install instructions
([#1315 ](https://github.com/haskell/haskell-ide-engine/pull/1315), by @friedbrice)
- Fix liquid unit test normalizing paths
([#1310 ](https://github.com/haskell/haskell-ide-engine/pull/1310), by @jneira)
- Add unix-time constraint to cabal file
([#1306 ](https://github.com/haskell/haskell-ide-engine/pull/1306), by @alanz)
- Fix a memory leak found by @mpickering
([#1305 ](https://github.com/haskell/haskell-ide-engine/pull/1305), by @lorenzo)
- Fix build for Windows 7
([#1304 ](https://github.com/haskell/haskell-ide-engine/pull/1304), by @jneira)
- Brittany 0.12
([#1301 ](https://github.com/haskell/haskell-ide-engine/pull/1301), by @alanz)
- Use ghc-mod without memory leak
([#1299 ](https://github.com/haskell/haskell-ide-engine/pull/1299), by @alanz)
- install.hs: Make all available GHCs in PATH buildable
([#1297 ](https://github.com/haskell/haskell-ide-engine/pull/1297), by @maoe)
- Fix file mapping state when we have a parsed module but not a typechecked module
([#1295 ](https://github.com/haskell/haskell-ide-engine/pull/1295), by @wz1000)
- Use ghc-mod which loads ghc plugins
([#1293 ](https://github.com/haskell/haskell-ide-engine/pull/1293), by @alanz)
- Fix UriCaches being leaked (bug fix)
([#1292 ](https://github.com/haskell/haskell-ide-engine/pull/1292), by @bubba)
- Stack 2.1.1
([#1291 ](https://github.com/haskell/haskell-ide-engine/pull/1291), by @alanz)
- Render completion documentation to markdown
([#1290 ](https://github.com/haskell/haskell-ide-engine/pull/1290), by @Avi-D-coder)
- Trying out haskell-lsp 0.14
([#1288 ](https://github.com/haskell/haskell-ide-engine/pull/1288), by @alanz)
- Hlint 2.1.24
([#1287 ](https://github.com/haskell/haskell-ide-engine/pull/1287), by @alanz)
- Improve import action of hsimport
([#1284 ](https://github.com/haskell/haskell-ide-engine/pull/1284), by @fendor)
- Add liquid haskell smt solver to README
([#1283 ](https://github.com/haskell/haskell-ide-engine/pull/1283), by @fendor)
# 0.10.0.0
- Drop GHC 8.2.1 support.
([#1279](https://github.com/haskell/haskell-ide-engine/pull/1279),
@alanz)
- Bump resolvers and hoogle, LTS 13.23 for GHC 8.6.5,
nightly-2019-05-31 for stack.yaml and hoogle version 5.0.17.9
([#1277](https://github.com/haskell/haskell-ide-engine/pull/1277),
@alanz)
- HsImport importlist, Offers code action to add a function to import list.
([#1170](https://github.com/haskell/haskell-ide-engine/pull/1170), @fendor)
- Typemap reimplementation
([#1186](https://github.com/haskell/haskell-ide-engine/pull/1186), @fendor)
- Add window/progress reporting for typechecking. Note: needs LSP
client to support a recent spec change.
([#1190](https://github.com/haskell/haskell-ide-engine/pull/1190),
@bubba)
- Add package to library component in package.yaml
([#1237](https://github.com/haskell/haskell-ide-engine/pull/1237), @fendor)
- hie sends invalid message on hover
([#1246](https://github.com/haskell/haskell-ide-engine/pull/1246), @Hogeyama)
- Use floskell from hackage
([#1242](https://github.com/haskell/haskell-ide-engine/pull/1242), @bubba)
- Adapting to new haskell-lsp
([#1247](https://github.com/haskell/haskell-ide-engine/pull/1247), @alanz)
- Remove HoverContentsEmpty
([#1251](https://github.com/haskell/haskell-ide-engine/pull/1251), @alanz)
- Use lsp-test-0.5.2.2 from hackage
([#1252](https://github.com/haskell/haskell-ide-engine/pull/1252), @bubba)
- Use haskell-lsp-12.1.0 from hackage
([#1253](https://github.com/haskell/haskell-ide-engine/pull/1253), @alanz)
- Bump haskell-lsp to 0.13.0.0
([#1260](https://github.com/haskell/haskell-ide-engine/pull/1260), @alanz)
- Bump version for hsimport to 0.10.0
([#1265](https://github.com/haskell/haskell-ide-engine/pull/1265), @fendor)
- Revert "Revert "Merge pull request #1237 from fendor/add-package-tests""
([#1268](https://github.com/haskell/haskell-ide-engine/pull/1268), @alanz)
- Hlint 2.1.22
([#1270](https://github.com/haskell/haskell-ide-engine/pull/1270), @alanz)
- Documentation
- Add Nix cabal-helper fix to troubleshooting section
([#1231](https://github.com/haskell/haskell-ide-engine/pull/1231),
@Infinisil)
- Troubleshooting for emacs
([#1240](https://github.com/haskell/haskell-ide-engine/pull/1240),
@Infinisil)
- Change url for nix installation instructions
([#1258](https://github.com/haskell/haskell-ide-engine/pull/1258),
@malob)
- Preparations for hie-bios
- HaRe hie plugin api
([#1215](https://github.com/haskell/haskell-ide-engine/pull/1215),
@alanz)
- Narrow ghc mod core
([#1255](https://github.com/haskell/haskell-ide-engine/pull/1255),
@alanz)
- Build system (install.hs)
- Extra argument causes cabal-build-doc to fail
([#1239](https://github.com/haskell/haskell-ide-engine/pull/1239),
@bflyblue)
- Add an explicit stack file for GHC 8.6.5
([#1241](https://github.com/haskell/haskell-ide-engine/pull/1241),
@alanz)
- Bump shake resolver
([#1272](https://github.com/haskell/haskell-ide-engine/pull/1272),
@fendor)
- Avoid legacy warning
([#1273](https://github.com/haskell/haskell-ide-engine/pull/1273),
@fendor)
# 0.9.0.0
- GHC 8.6.5 preliminary support added via the nightly build (@alanz)

34
README.md
View File

@ -63,6 +63,7 @@ we talk to clients.__
- [Is there a hash (#) after \<package\>?](#is-there-a-hash--after-package)
- [Otherwise](#otherwise)
- [Nix: cabal-helper, No such file or directory](#nix-cabal-helper-no-such-file-or-directory)
- [Liquid Haskell](#liquid-haskell)
## Features
@ -128,12 +129,12 @@ Follow the instructions at https://github.com/Infinisil/all-hies
### Installation on ArchLinux
An [haskell-ide-engine-git](https://aur.archlinux.org/packages/haskell-ide-engine-git/) package is available on the AUR.
An [haskell-ide-engine](https://aur.archlinux.org/packages/haskell-ide-engine/) package is available on the AUR.
Using [Aura](https://github.com/aurapm/aura):
```
# aura -A haskell-ide-engine-git
# aura -A haskell-ide-engine
```
@ -200,6 +201,20 @@ stack ./install.hs help
Remember, this will take time to download a Stackage-LTS and an appropriate GHC. However, afterwards all commands should work as expected.
##### Install via cabal
The install-script can be invoked via `cabal` instead of `stack` with the command
```bash
cabal v2-run ./install.hs --project-file install/shake.project <target>
```
Running the script with cabal on windows seems to have some issues and is currently not fully supported.
Unfortunately, it is still required to have `stack` installed so that the install-script can locate the `local-bin` directory (on Linux `~/.local/bin`) and copy the `hie` binaries to `hie-x.y.z`, which is required for the `hie-wrapper` to function as expected.
For brevity, only the `stack`-based commands are presented in the following sections.
##### Install specific GHC Version
Install **Nightly** (and hoogle docs):
@ -345,7 +360,7 @@ in
}
```
Now open a haskell project with Sublime Text. You should have these features available to you:
Now open a Haskell project with Sublime Text. You should have these features available to you:
1. Errors are underlined in red
2. LSP: Show Diagnostics will show a list of hints and errors
@ -356,8 +371,8 @@ Now open a haskell project with Sublime Text. You should have these features ava
As above, make sure HIE is installed. These instructions are for using the [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) client.
#### vim-plug
If you use [vim-plug](https://github.com/junegunn/vim-plug), then you can do this by e.g.
including the following line in the Plug section of your `init.vim`:
If you use [vim-plug](https://github.com/junegunn/vim-plug), then you can do this by e.g.,
including the following line in the Plug section of your `init.vim` or `~/.vimrc`:
```
Plug 'autozimu/LanguageClient-neovim', {
@ -366,10 +381,10 @@ Plug 'autozimu/LanguageClient-neovim', {
\ }
```
and issuing a `:PlugInstall` command within neovim.
and issuing a `:PlugInstall` command within Neovim or Vim.
#### Vim 8.0
Clone [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)
#### Clone the LanguageClient-neovim repo
As an alternative to using [vim-plug](https://github.com/junegunn/vim-plug) shown above, clone [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)
into `~/.vim/pack/XXX/start/`, where `XXX` is just a name for your "plugin suite".
#### Sample `~/.vimrc`
@ -629,4 +644,7 @@ cabal-helper-wrapper: /home/<...>/.cache/cabal-helper/cabal-helper<...>: createP
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.

1
appveyor.yml
View File

@ -8,7 +8,6 @@ environment:
- GHCVER: 8.4.3
- GHCVER: 8.4.2
- GHCVER: 8.2.2
- GHCVER: 8.2.1
install:
- cmd: >-
git submodule update --init --recursive

7
azure-pipelines.yml Normal file
View File

@ -0,0 +1,7 @@
jobs:
- template: ./.azure/linux-stack.yml
- template: ./.azure/windows-stack.yml
- template: ./.azure/macos-stack.yml
- template: ./.azure/linux-installhs-stack.yml
- template: ./.azure/windows-installhs-stack.yml
- template: ./.azure/macos-installhs-stack.yml

1
cabal.project
View File

@ -4,7 +4,6 @@ packages:
./hie-bios/
./submodules/HaRe
./submodules/brittany
./submodules/cabal-helper/
./submodules/ghc-mod/
./submodules/ghc-mod/core/

16
docs/Challenges.md
View File

@ -2,15 +2,15 @@
### ghc-mod
1. Linking aginst Cabal directly meant lots of breakage when interacting with the on disk configuration state. (Since solved by using wrapper)
2. Supporting ill defined interfaces and protocols is hard to impossible. Over the course of it's almost 100 releases (!!!) compatibility was broken way too often.
3. Supporting many GHC versions simultaniously is very hard since they keep breaking the API.
4. Linking against GHC means simmilar problems as with linking against Cabal, i.e. when the user upgrades their GHC binary stuff will break.
1. Linking against Cabal directly meant lots of breakage when interacting with the on-disk configuration state. (Since solved by using wrapper)
2. Supporting ill-defined interfaces and protocols is hard to impossible. Over the course of its almost 100 releases (!!!) compatibility was broken way too often.
3. Supporting many GHC versions simultaneously is very hard since they keep breaking the API.
4. Linking against GHC means similar problems as with linking against Cabal, i.e., when the user upgrades their GHC binary stuff will break.
:memo: Don't link against Cabal directly ever
:memo: (maybe) Target only one GHC version at a time or provide some compatibility layer
:memo: Let's get the interfaces mostly right on the first go
:memo: Handle changing compiler versions transparently
* :memo: Don't link against Cabal directly ever
* :memo: (maybe) Target only one GHC version at a time or provide some compatibility layer
* :memo: Let's get the interfaces mostly right on the first go
* :memo: Handle changing compiler versions transparently
### ide-backend / stack-ide

14
haskell-ide-engine.cabal
View File

@ -69,8 +69,8 @@ library
, gitrev >= 1.1
, haddock-api
, haddock-library
, haskell-lsp == 0.13.*
, haskell-lsp-types == 0.13.*
, haskell-lsp == 0.15.*
, haskell-lsp-types == 0.15.*
, haskell-src-exts
, hie-plugin-api
, hlint (>= 2.0.11 && < 2.1.18) || >= 2.1.22
@ -91,8 +91,10 @@ library
, tagsoup
, text
, transformers
, unix-time >= 0.4.7
, unordered-containers
, vector
, versions
, yaml >= 0.8.31
, hie-bios
, bytestring-trie
@ -192,7 +194,7 @@ test-suite unit-test
, filepath
, free
, haskell-ide-engine
, haskell-lsp-types
, haskell-lsp-types >= 0.15.0.0
, hie-test-utils
, hie-plugin-api
, hoogle > 5.0.11
@ -278,10 +280,10 @@ test-suite func-test
, data-default
, directory
, filepath
, lsp-test >= 0.5.2
, lsp-test >= 0.6.0.0
, haskell-ide-engine
, haskell-lsp-types == 0.13.*
, haskell-lsp == 0.13.*
, haskell-lsp-types == 0.15.*
, haskell-lsp == 0.15.*
, hie-test-utils
, hie-plugin-api
, hspec

13
hie-plugin-api/Haskell/Ide/Engine/Config.hs
View File

@ -8,14 +8,23 @@ import Language.Haskell.LSP.Types
-- ---------------------------------------------------------------------
-- | Callback from haskell-lsp core to convert the generic message to the
-- specific one for hie
-- | Given a DidChangeConfigurationNotification message, this function returns the parsed
-- Config object if possible.
getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config
getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) =
case fromJSON p of
Success c -> Right c
Error err -> Left $ T.pack err
-- | Given an InitializeRequest message, this function returns the parsed
-- Config object if possible. Otherwise, it returns the default configuration
getInitialConfig :: InitializeRequest -> Either T.Text Config
getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def
getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) =
case fromJSON opts of
Success c -> Right c
Error err -> Left $ T.pack err
-- ---------------------------------------------------------------------
data Config =

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

@ -11,7 +11,7 @@
module Haskell.Ide.Engine.Ghc
(
setTypecheckedModule
, Diagnostics
, Diagnostics(..)
, AdditionalErrs
, cabalModuleGraphs
, makeRevRedirMapFunc
@ -21,9 +21,11 @@ import Bag
import Control.Monad.IO.Class
import Data.IORef
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import Data.Semigroup ((<>), Semigroup)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Aeson
import Data.Coerce
import ErrUtils
import Haskell.Ide.Engine.MonadFunctions
@ -36,6 +38,7 @@ import GHC
import IOEnv as G
import HscTypes
import Outputable (renderWithStyle)
import Language.Haskell.LSP.Types ( NormalizedUri(..), toNormalizedUri )
import Bag
import Control.Monad.IO.Class
@ -68,7 +71,20 @@ import qualified HscMain as G
import System.Directory
type Diagnostics = Map.Map Uri (Set.Set Diagnostic)
newtype Diagnostics = Diagnostics (Map.Map NormalizedUri (Set.Set Diagnostic))
deriving (Show, Eq)
instance Semigroup Diagnostics where
Diagnostics d1 <> Diagnostics d2 = Diagnostics (d1 <> d2)
instance Monoid Diagnostics where
mappend = (<>)
mempty = Diagnostics mempty
instance Data.Aeson.ToJSON Diagnostics where
toJSON (Diagnostics d) = Data.Aeson.toJSON
(Map.mapKeys coerce d :: Map.Map T.Text (Set.Set Diagnostic))
type AdditionalErrs = [T.Text]
@ -81,7 +97,30 @@ lspSev SevFatal = DsError
lspSev SevInfo = DsInfo
lspSev _ = DsInfo
-- | Turn a 'SourceError' into the HIE 'Diagnostics' format.
-- 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 ()
-- ---------------------------------------------------------------------
-- unhelpfulSrcSpanErr :: T.Text -> IdeError
-- unhelpfulSrcSpanErr err =
-- IdeError PluginError
-- ("Unhelpful SrcSpan" <> ": \"" <> err <> "\"")
-- Null
-- ---------------------------------------------------------------------
srcErrToDiag :: MonadIO m
=> DynFlags
-> (FilePath -> FilePath)
@ -105,9 +144,11 @@ srcErrToDiag df rfm se = do
(m,es) <- processMsgs xs
case res of
Right (uri, diag) ->
return (Map.insertWith Set.union uri (Set.singleton diag) m, es)
return (Map.insertWith Set.union (toNormalizedUri uri) (Set.singleton diag) m, es)
Left e -> return (m, e:es)
processMsgs errMsgs
(diags, errs) <- processMsgs errMsgs
return (Diagnostics diags, errs)
-- | Run a Ghc action and capture any diagnostics and errors produced.
@ -117,10 +158,12 @@ captureDiagnostics :: (MonadIO m, GhcMonad m)
-> m (Diagnostics, AdditionalErrs, Maybe r)
captureDiagnostics rfm action = do
env <- getSession
diagRef <- liftIO $ newIORef Map.empty
diagRef <- liftIO $ newIORef mempty
errRef <- liftIO $ newIORef []
let setLogger df = df { log_action = logDiag rfm errRef diagRef }
setDeferTypedHoles = setGeneralFlag' Opt_DeferTypedHoles
ghcErrRes :: String -> (Diagnostics, AdditionalErrs)
ghcErrRes msg = do
diags <- liftIO $ readIORef diagRef
errs <- liftIO $ readIORef errRef
@ -132,7 +175,7 @@ captureDiagnostics rfm action = do
return (Map.unionWith Set.union d1 diags, e1 ++ errs, Nothing)
handlers = errorHandlers ghcErrRes to_diag
handlers = errorHandlers ghcErrRes (srcErrToDiag (hsc_dflags env) rfm )
action' = do
r <- BIOS.withDynFlags (setLogger . setDeferTypedHoles) action
diags <- liftIO $ readIORef diagRef
@ -223,7 +266,23 @@ setTypecheckedModule_load uri =
let progTitle = "Typechecking " <> T.pack (takeFileName fp)
(diags', errs, mmods) <- loadFile rfm (fp, mapped_fp)
debugm "File, loaded"
canonUri <- canonicalizeUri uri
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)
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))
canonUri <- toNormalizedUri <$> canonicalizeUri uri
let diags = Map.insertWith Set.union canonUri Set.empty diags'
debugm "setTypecheckedModule: after ghc-mod"
debugm ("Diags: " <> show diags')
@ -261,7 +320,7 @@ setTypecheckedModule_load uri =
let d = Diagnostic range sev Nothing (Just "bios") msgTxt Nothing
return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
return $ IdeResultOk (diags2,errs)
return $ IdeResultOk (Diagnostics diags2,errs)
--
cabalModuleGraphs = undefined

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

@ -280,9 +280,13 @@ cacheModule fp modul = do
let defInfo = CachedInfo mempty mempty mempty mempty rfm return return
return $ case muc of
Just (UriCacheSuccess uc) ->
let newCI = (cachedInfo uc) { revMap = rfm }
in uc { cachedPsMod = pm, cachedInfo = newCI, cachedHash = fp_hash }
_ -> UriCache defInfo pm Nothing mempty fp_hash
let newCI = oldCI { revMap = rfm . revMap oldCI }
-- ^^^^^^^^^^^^
-- We have to retain the old mapping state, since the
-- old TypecheckedModule still contains spans relative to that
oldCI = cachedInfo uc
in uc { cachedPsMod = pm, cachedInfo = newCI }
_ -> UriCache defInfo pm Nothing mempty
Right tm -> do
typm <- genTypeMap tm

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

@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveAnyClass #-}
@ -152,6 +153,7 @@ import Language.Haskell.LSP.Types ( Command(..)
, WorkspaceEdit(..)
, filePathToUri
, uriToFilePath
, toNormalizedUri
)
import Language.Haskell.LSP.VFS ( VirtualFile(..) )
@ -412,7 +414,7 @@ getVirtualFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe VirtualFile)
getVirtualFile uri = do
mlf <- ideEnvLspFuncs <$> getIdeEnv
case mlf of
Just lf -> liftIO $ Core.getVirtualFileFunc lf uri
Just lf -> liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri)
Nothing -> return Nothing
persistVirtualFile :: (MonadIde m, MonadIO m) => Uri -> m FilePath
@ -472,7 +474,7 @@ withIndefiniteProgress t c f = do
Just wp -> control $ \run -> wp t c (run f)
data IdeState = IdeState
{ moduleCache :: GhcModuleCache
{ moduleCache :: !GhcModuleCache
-- | A queue of requests to be performed once a module is loaded
, requestQueue :: Map.Map FilePath [UriCacheResult -> IdeM ()]
, extensibleState :: !(Map.Map TypeRep Dynamic)
@ -516,7 +518,7 @@ instance HasGhcModuleCache IdeM where
tvar <- lift ask
state <- readTVarIO tvar
return (moduleCache state)
setModuleCache mc = do
setModuleCache !mc = do
tvar <- lift ask
atomically $ modifyTVar' tvar (\st -> st { moduleCache = mc })

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

@ -1,5 +1,5 @@
name: hie-plugin-api
version: 0.9.0.0
version: 0.11.0.0
synopsis: Haskell IDE API for plugin communication
license: BSD3
license-file: LICENSE
@ -50,7 +50,7 @@ library
, ghc
, hie-bios
, ghc-project-types >= 5.9.0.0
, haskell-lsp == 0.13.*
, haskell-lsp == 0.15.*
, hslogger
, unliftio
, monad-control

598
install.hs
View File

@ -1,592 +1,20 @@
#!/usr/bin/env stack
{- stack
runghc
--stack-yaml=shake.yaml
--package shake
--package directory
--package extra
--stack-yaml=install/shake.yaml
--package hie-install
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Control.Monad
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Extra ( unlessM
, mapMaybeM
)
import Data.Maybe ( isJust )
import System.Directory ( findExecutable
, listDirectory
)
import System.Environment ( getProgName
, unsetEnv
)
import System.Info ( os
, arch
)
{- cabal:
build-depends:
base
, hie-install
-}
-- call as:
-- * `cabal v2-run install.hs --project-file install/shake.project <target>`
-- * `stack install.hs <target>`
import Data.Maybe ( isNothing
, mapMaybe
)
import Data.List ( dropWhileEnd
, intersperse
, intercalate
, sort
)
import qualified Data.Text as T
import Data.Char ( isSpace )
import Data.Version ( parseVersion
, makeVersion
, showVersion
)
import Data.Function ( (&) )
import Text.ParserCombinators.ReadP ( readP_to_S )
-- TODO: set `shake.project` in cabal-config above, when supported
type VersionNumber = String
type GhcPath = String
import HieInstall (defaultMain)
-- | Defines all different hie versions that are buildable.
--
-- The current directory is scanned for `stack-*.yaml` files.
-- On windows, `8.6.3` is excluded as this version of ghc does not work there
getHieVersions :: MonadIO m => m [VersionNumber]
getHieVersions = do
let stackYamlPrefix = T.pack "stack-"
let stackYamlSuffix = T.pack ".yaml"
files <- liftIO $ listDirectory "."
let hieVersions = files
& map T.pack
& mapMaybe
(T.stripPrefix stackYamlPrefix >=> T.stripSuffix stackYamlSuffix)
& map T.unpack
-- the following line excludes `8.6.3` on windows systems
& filter (\p -> not isWindowsSystem || p /= "8.6.3")
& sort
return hieVersions
-- | Most recent version of hie.
-- Shown in the more concise help message.
mostRecentHieVersion :: MonadIO m => m VersionNumber
mostRecentHieVersion = last <$> getHieVersions
main :: IO ()
main = do
-- unset GHC_PACKAGE_PATH for cabal
unsetEnv "GHC_PACKAGE_PATH"
ghcPaths <- findInstalledGhcs
let ghcVersions = map fst ghcPaths
hieVersions <- getHieVersions
shakeArgs shakeOptions { shakeFiles = "_build" } $ do
want ["short-help"]
-- general purpose targets
phony "submodules" updateSubmodules
phony "cabal" installCabal
phony "short-help" shortHelpMessage
phony "all" shortHelpMessage
phony "help" helpMessage
phony "check-stack" checkStack
phony "cabal-ghcs" $ do
let
msg =
"Found the following GHC paths: \n"
++ unlines
(map (\(version, path) -> "ghc-" ++ version ++ ": " ++ path)
ghcPaths
)
liftIO $ putStrLn $ embedInStars msg
-- stack specific targets
phony "build" (need (reverse $ map ("hie-" ++) hieVersions))
phony "build-all" (need ["build-doc", "build"])
phony "test" $ do
need ["submodules"]
need ["check-stack"]
need ["cabal"]
forM_ hieVersions stackTest
phony "build-copy-compiler-tool" $ forM_ hieVersions buildCopyCompilerTool
phony "build-doc" $ do
need ["submodules"]
need ["check-stack"]
stackBuildDoc
-- main targets for building hie with `stack`
forM_
hieVersions
(\version -> phony ("hie-" ++ version) $ do
need ["submodules"]
need ["check-stack"]
need ["cabal"]
stackBuildHie version
stackInstallHie version
)
-- cabal specific targets
phony "cabal-build" (need (map ("cabal-hie-" ++) ghcVersions))
phony "cabal-build-all" (need ["cabal-build-doc", "cabal-build"])
phony "cabal-build-doc" $ do
need ["submodules"]
need ["cabal"]
cabalBuildDoc
phony "cabal-test" $ do
need ["submodules"]
need ["cabal"]
forM_ ghcVersions cabalTest
forM_
hieVersions
(\version -> phony ("cabal-hie-" ++ version) $ do
validateCabalNewInstallIsSupported
need ["submodules"]
need ["cabal"]
cabalBuildHie version
cabalInstallHie version
)
-- macos specific targets
phony "icu-macos-fix"
(need ["icu-macos-fix-install"] >> need ["icu-macos-fix-build"])
phony "icu-macos-fix-install" (command_ [] "brew" ["install", "icu4c"])
phony "icu-macos-fix-build" $ mapM_ buildIcuMacosFix hieVersions
buildIcuMacosFix :: VersionNumber -> Action ()
buildIcuMacosFix version = execStackWithGhc_
version
[ "build"
, "text-icu"
, "--extra-lib-dirs=/usr/local/opt/icu4c/lib"
, "--extra-include-dirs=/usr/local/opt/icu4c/include"
]
-- | update the submodules that the project is in the state as required by the `stack.yaml` files
updateSubmodules :: Action ()
updateSubmodules = do
command_ [] "git" ["submodule", "sync", "--recursive"]
command_ [] "git" ["submodule", "update", "--init", "--recursive"]
-- TODO: this restriction will be gone in the next release of cabal
validateCabalNewInstallIsSupported :: Action ()
validateCabalNewInstallIsSupported = when isWindowsSystem $ do
liftIO $ putStrLn $ embedInStars cabalInstallNotSuportedFailMsg
error cabalInstallNotSuportedFailMsg
configureCabal :: VersionNumber -> Action ()
configureCabal versionNumber = do
ghcPath <- getGhcPath versionNumber >>= \case
Nothing -> do
liftIO $ putStrLn $ embedInStars (ghcVersionNotFoundFailMsg versionNumber)
error (ghcVersionNotFoundFailMsg versionNumber)
Just p -> return p
execCabal_
["new-configure", "-w", ghcPath, "--write-ghc-environment-files=never"]
findInstalledGhcs :: IO [(VersionNumber, GhcPath)]
findInstalledGhcs = do
hieVersions <- getHieVersions :: IO [VersionNumber]
mapMaybeM
(\version -> getGhcPath version >>= \case
Nothing -> return Nothing
Just p -> return $ Just (version, p)
)
(reverse hieVersions)
cabalBuildHie :: VersionNumber -> Action ()
cabalBuildHie versionNumber = do
configureCabal versionNumber
execCabal_ ["new-build", "--write-ghc-environment-files=never"]
cabalInstallHie :: VersionNumber -> Action ()
cabalInstallHie versionNumber = do
localBin <- getLocalBin
execCabal_
[ "new-install"
, "--write-ghc-environment-files=never"
, "--symlink-bindir=" ++ localBin
, "exe:hie"
, "--overwrite-policy=always"
]
copyFile' (localBin </> "hie" <.> exe)
(localBin </> "hie-" ++ versionNumber <.> exe)
copyFile' (localBin </> "hie" <.> exe)
(localBin </> "hie-" ++ dropExtension versionNumber <.> exe)
cabalBuildDoc :: Action ()
cabalBuildDoc = do
execCabal_ ["new-build", "hoogle"]
execCabal_ ["new-exec", "hoogle", "generate"]
cabalTest :: VersionNumber -> Action ()
cabalTest versionNumber = do
configureCabal versionNumber
execCabal_ ["new-test"]
installCabal :: Action ()
installCabal = do
-- try to find existing `cabal` executable with appropriate version
cabalExe <- liftIO (findExecutable "cabal") >>= \case
Nothing -> return Nothing
Just cabalExe -> do
Stdout cabalVersion <- execCabal ["--numeric-version"]
let (parsedVersion, "") : _ =
cabalVersion & trim & readP_to_S parseVersion & filter
(("" ==) . snd)
return $ if parsedVersion >= makeVersion [2, 4, 1, 0]
then Just cabalExe
else Nothing
-- install `cabal-install` if not already installed
when (isNothing cabalExe) $
execStackShake_ ["install", "cabal-install"]
execCabal_ ["update"]
checkStack :: Action ()
checkStack = do
Stdout stackVersion <- execStackShake ["--numeric-version"]
let (parsedVersion, "") : _ =
stackVersion & trim & readP_to_S parseVersion & filter
(("" ==) . snd)
unless (parsedVersion >= makeVersion requiredStackVersion) $ do
liftIO $ putStrLn $ embedInStars $ stackExeIsOldFailMsg $ trim stackVersion
error $ stackExeIsOldFailMsg $ trim stackVersion
stackBuildHie :: VersionNumber -> Action ()
stackBuildHie versionNumber =
execStackWithGhc_ versionNumber ["build"]
`actionOnException` liftIO (putStrLn stackBuildFailMsg)
-- | copy the built binaries into the localBinDir
stackInstallHie :: VersionNumber -> Action ()
stackInstallHie versionNumber = do
execStackWithGhc_ versionNumber ["install"]
localBinDir <- getLocalBin
localInstallRoot <- getLocalInstallRoot versionNumber
let hie = "hie" <.> exe
copyFile' (localInstallRoot </> "bin" </> hie)
(localBinDir </> "hie-" ++ versionNumber <.> exe)
copyFile' (localInstallRoot </> "bin" </> hie)
(localBinDir </> "hie-" ++ dropExtension versionNumber <.> exe)
buildCopyCompilerTool :: VersionNumber -> Action ()
buildCopyCompilerTool versionNumber =
execStackWithGhc_ versionNumber ["build", "--copy-compiler-tool"]
stackTest :: VersionNumber -> Action ()
stackTest versionNumber = execStackWithGhc_ versionNumber ["test"]
stackBuildDoc :: Action ()
stackBuildDoc = do
execStackShake_ ["build", "hoogle"]
execStackShake_ ["exec", "hoogle", "generate"]
-- | short help message is printed by default
shortHelpMessage :: Action ()
shortHelpMessage = do
hieVersions <- getHieVersions
let out = liftIO . putStrLn
scriptName <- liftIO getProgName
out ""
out "Usage:"
out' ("stack " <> scriptName <> " <target>")
out ""
out "Targets:"
mapM_ (out' . showTarget (spaces hieVersions)) (targets hieVersions)
out ""
where
out = liftIO . putStrLn
out' = out . (" " ++)
spaces hieVersions = space (targets hieVersions)
targets hieVersions =
[ ("help", "Show help message including all targets")
, emptyTarget
, ( "build"
, "Builds hie for all supported GHC versions ("
++ allVersionMessage hieVersions
++ ")"
)
, stackBuildAllTarget
-- , stackHieTarget mostRecentHieVersion
, stackBuildDocTarget
, stackHieTarget (last hieVersions)
, emptyTarget
, ( "cabal-ghcs"
, "Show all GHC versions that can be installed via `cabal-build` and `cabal-build-all`."
)
, cabalBuildTarget
, cabalBuildAllTarget
-- , cabalHieTarget mostRecentHieVersion
, cabalBuildDocTarget
, cabalHieTarget (last hieVersions)
]
helpMessage :: Action ()
helpMessage = do
hieVersions <- getHieVersions
scriptName <- liftIO getProgName
out ""
out "Usage:"
out' ("stack " <> scriptName <> " <target>")
out ""
out "Targets:"
mapM_ (out' . showTarget (spaces hieVersions)) (targets hieVersions)
out ""
where
out = liftIO . putStrLn
out' = out . (" " ++)
spaces hieVersions = space (targets hieVersions)
-- All targets the shake file supports
targets :: [VersionNumber] -> [(String, String)]
targets hieVersions = intercalate
[emptyTarget]
[ generalTargets
, stackTargets hieVersions
, cabalTargets hieVersions
, macosTargets
]
-- All targets with their respective help message.
generalTargets =
[ ("help", "Show help message including all targets")
, ( "cabal"
, "Makes sure that Cabal the lib is available for cabal-helper-wapper, to speed up project start"
)
]
macosTargets = [("icu-macos-fix", "Fixes icu related problems in MacOS")]
stackTargets hieVersions =
[ ( "build"
, "Builds hie for all supported GHC versions ("
++ allVersionMessage hieVersions
++ ")"
)
, stackBuildAllTarget
, stackBuildDocTarget
, ("test", "Runs hie tests with stack")
]
++ map stackHieTarget hieVersions
cabalTargets hieVersions =
[ ( "cabal-ghcs"
, "Show all GHC versions that can be installed via `cabal-build` and `cabal-build-all`."
)
, cabalBuildTarget
, cabalBuildAllTarget
, cabalBuildDocTarget
, ("cabal-test", "Runs hie tests with cabal")
]
++ map cabalHieTarget hieVersions
-- | Empty target. Purpose is to introduce a newline between the targets
emptyTarget :: (String, String)
emptyTarget = ("", "")
-- | Number of spaces the target name including whitespace should have.
-- At least twenty, maybe more if target names are long. At most the length of the longest target plus five.
space :: [(String, String)] -> Int
space phonyTargets = maximum (20 : map ((+ 5) . length . fst) phonyTargets)
-- | Show a target.
-- Concatenates the target with its help message and inserts whitespace between them.
showTarget :: Int -> (String, String) -> String
showTarget spaces (target, msg) =
target ++ replicate (spaces - length target) ' ' ++ msg
-- | Target for a specific ghc version
stackHieTarget :: String -> (String, String)
stackHieTarget version =
( "hie-" ++ version
, "Builds hie for GHC version " ++ version ++ " only with stack"
)
-- | Target for a specific ghc version
cabalHieTarget :: String -> (String, String)
cabalHieTarget version =
( "cabal-hie-" ++ version
, "Builds hie for GHC version " ++ version ++ " only with cabal new-build"
)
stackBuildDocTarget :: (String, String)
stackBuildDocTarget = ("build-doc", "Builds the Hoogle database")
stackBuildAllTarget :: (String, String)
stackBuildAllTarget =
( "build-all"
, "Builds hie for all supported GHC versions and the hoogle database"
)
cabalBuildTarget :: (String, String)
cabalBuildTarget =
("cabal-build", "Builds hie with cabal with all installed GHCs.")
cabalBuildDocTarget :: (String, String)
cabalBuildDocTarget =
("cabal-build-doc", "Builds the Hoogle database with cabal")
cabalBuildAllTarget :: (String, String)
cabalBuildAllTarget =
( "cabal-build-all"
, "Builds hie for all installed GHC versions and the hoogle database with cabal"
)
-- | Creates a message of the form "a, b, c and d", where a,b,c,d are GHC versions.
-- If there is no GHC in the list of `hieVersions`
allVersionMessage :: [String] -> String
allVersionMessage wordList = case wordList of
[] -> ""
[a] -> show a
(a : as) ->
let msg = intersperse ", " wordList
lastVersion = last msg
in concat $ (init $ init msg) ++ [" and ", lastVersion]
-- RUN EXECUTABLES
-- | Execute a stack command for a specified ghc, discarding the output
execStackWithGhc_ :: VersionNumber -> [String] -> Action ()
execStackWithGhc_ versionNumber args = do
let stackFile = "stack-" ++ versionNumber ++ ".yaml"
command_ [] "stack" (("--stack-yaml=" ++ stackFile) : args)
-- | Execute a stack command for a specified ghc
execStackWithGhc :: CmdResult r => VersionNumber -> [String] -> Action r
execStackWithGhc versionNumber args = do
let stackFile = "stack-" ++ versionNumber ++ ".yaml"
command [] "stack" (("--stack-yaml=" ++ stackFile) : args)
-- | Execute a stack command with the same resolver as the build script
execStackShake :: CmdResult r => [String] -> Action r
execStackShake args =
command [] "stack" ("--stack-yaml=shake.yaml" : args)
-- | Execute a stack command with the same resolver as the build script, discarding the output
execStackShake_ :: [String] -> Action ()
execStackShake_ args =
command_ [] "stack" ("--stack-yaml=shake.yaml" : args)
execCabal :: CmdResult r => [String] -> Action r
execCabal =
command [] "cabal"
execCabal_ :: [String] -> Action ()
execCabal_ = command_ [] "cabal"
existsExecutable :: MonadIO m => String -> m Bool
existsExecutable executable = liftIO $ isJust <$> findExecutable executable
-- QUERY ENVIRONMENT
-- |Check if the current system is windows
isWindowsSystem :: Bool
isWindowsSystem = os `elem` ["mingw32", "win32"]
-- | Get the path to the GHC compiler executable linked to the local `stack-$GHCVER.yaml`.
-- Equal to the command `stack path --stack-yaml $stack-yaml --compiler-exe`.
-- This might install a GHC if it is not already installed, thus, might fail if stack fails to install the GHC.
getStackGhcPath :: VersionNumber -> Action GhcPath
getStackGhcPath ghcVersion = do
Stdout ghc <- execStackWithGhc ghcVersion ["path", "--compiler-exe"]
return $ trim ghc
getStackGhcPathShake :: Action GhcPath
getStackGhcPathShake = do
Stdout ghc <- execStackShake ["path", "--compiler-exe"]
return $ trim ghc
-- | Get the path to a GHC that has the version specified by `VersionNumber`
-- If no such GHC can be found, Nothing is returned.
-- First, it is checked whether there is a GHC with the name `ghc-$VersionNumber`.
-- If this yields no result, it is checked, whether the numeric-version of the `ghc`
-- command fits to the desired version.
getGhcPath :: MonadIO m => VersionNumber -> m (Maybe GhcPath)
getGhcPath ghcVersion = liftIO $
findExecutable ("ghc-" ++ ghcVersion) >>= \case
Nothing -> do
findExecutable "ghc" >>= \case
Nothing -> return Nothing
Just p -> do
Stdout version <- cmd p ["--numeric-version"] :: IO (Stdout String)
if ghcVersion == trim version then return $ Just p else return Nothing
p -> return p
-- | Read the local install root of the stack project specified by the VersionNumber
-- Returns the filepath of the local install root.
-- Equal to the command `stack path --local-install-root`
getLocalInstallRoot :: VersionNumber -> Action FilePath
getLocalInstallRoot hieVersion = do
Stdout localInstallRoot' <- execStackWithGhc
hieVersion
["path", "--local-install-root"]
return $ trim localInstallRoot'
-- | Get the local binary path of stack.
-- Equal to the command `stack path --local-bin`
getLocalBin :: Action FilePath
getLocalBin = do
Stdout stackLocalDir' <- execStackShake
["path", "--local-bin"]
return $ trim stackLocalDir'
-- | Trim the end of a string
trim :: String -> String
trim = dropWhileEnd isSpace
-- | Embed a string within two lines of stars to improve perceivability and, thus, readability.
embedInStars :: String -> String
embedInStars str =
let starsLine
= "\n******************************************************************\n"
in starsLine <> str <> starsLine
-- |Stack build fails message
stackBuildFailMsg :: String
stackBuildFailMsg =
embedInStars
$ "Building failed, "
++ "Try running `stack clean` and restart the build\n"
++ "If this does not work, open an issue at \n"
++ "\thttps://github.com/haskell/haskell-ide-engine"
-- | No suitable ghc version has been found. Show a message.
ghcVersionNotFoundFailMsg :: VersionNumber -> String
ghcVersionNotFoundFailMsg versionNumber =
"No GHC with version "
<> versionNumber
<> " has been found.\n"
<> "Either install a fitting GHC, use the stack targets or modify the PATH variable accordingly."
-- | Error message when a windows system tries to install HIE via `cabal new-install`
cabalInstallNotSuportedFailMsg :: String
cabalInstallNotSuportedFailMsg =
"This system has been identified as a windows system.\n"
++ "Unfortunately, `cabal new-install` is currently not supported on windows.\n"
++ "Please 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"
-- | Error message when the `stack` binary is an older version
stackExeIsOldFailMsg :: String -> String
stackExeIsOldFailMsg stackVersion =
"The `stack` executable is outdated.\n"
++ "found version is `" ++ stackVersion ++ "`.\n"
++ "required version is `" ++ showVersion (makeVersion requiredStackVersion) ++ "`.\n"
++ "Please run `stack upgrade` to upgrade your stack installation"
requiredStackVersion :: [Int]
requiredStackVersion = [1, 9, 3]
main = defaultMain

2
install/Setup.hs Normal file
View File

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

2
install/cabal.project Normal file
View File

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

37
install/hie-install.cabal Normal file
View File

@ -0,0 +1,37 @@
name: hie-install
version: 0.8.0.0
synopsis: Install the haskell-ide-engine
license: BSD3
author: Many, TBD when we release
maintainer: samuel.pilz@posteo.net
copyright: 2019
build-type: Simple
cabal-version: >=2.0
library
hs-source-dirs: src
exposed-modules: HieInstall
other-modules: BuildSystem
, Stack
, Version
, Cabal
, Print
, Env
, Help
build-depends: base >= 4.9 && < 5
, shake == 0.17.8
, directory
, extra
, text
default-extensions: LambdaCase
, TupleSections
, RecordWildCards
default-language: Haskell2010
if flag(run-from-stack)
cpp-options: -DRUN_FROM_STACK
flag run-from-stack
description: Inform the application that it is run from stack
default: False
manual: True

2
install/shake.project Normal file
View File

@ -0,0 +1,2 @@
packages:
install/

6
shake.yaml → install/shake.yaml
View File

@ -1,7 +1,11 @@
# Used to provide a different environment for the shake build script
resolver: nightly-2018-12-15 # GHC 8.6.2
resolver: lts-13.18 # GHC 8.6.4
packages:
- .
nix:
packages: [ zlib ]
flags:
hie-install:
run-from-stack: true

17
install/src/BuildSystem.hs Normal file
View File

@ -0,0 +1,17 @@
{-# LANGUAGE CPP #-}
module BuildSystem where
buildSystem :: String
buildSystem =
#if RUN_FROM_STACK
"stack"
#else
"cabal"
#endif
isRunFromStack :: Bool
isRunFromStack = buildSystem == "stack"
isRunFromCabal :: Bool
isRunFromCabal = buildSystem == "cabal"

108
install/src/Cabal.hs Normal file
View File

@ -0,0 +1,108 @@
module Cabal where
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Control.Monad
import Data.Maybe ( isNothing )
import Control.Monad.Extra ( whenMaybe )
import System.Directory ( findExecutable
, copyFile
)
import Version
import Print
import Env
import Stack
execCabal :: CmdResult r => [String] -> Action r
execCabal = command [] "cabal"
execCabal_ :: [String] -> Action ()
execCabal_ = command_ [] "cabal"
cabalBuildData :: Action ()
cabalBuildData = do
execCabal_ ["new-build", "hoogle"]
execCabal_ ["new-exec", "hoogle", "generate"]
cabalBuildHie :: VersionNumber -> Action ()
cabalBuildHie versionNumber = do
ghcPath <- getGhcPathOf versionNumber >>= \case
Nothing -> do
printInStars $ ghcVersionNotFoundFailMsg versionNumber
error (ghcVersionNotFoundFailMsg versionNumber)
Just p -> return p
execCabal_
["new-build", "-w", ghcPath, "--write-ghc-environment-files=never", "--max-backjumps=5000"]
cabalInstallHie :: VersionNumber -> Action ()
cabalInstallHie versionNumber = do
localBin <- getLocalBin
execCabal_
[ "new-install"
, "--write-ghc-environment-files=never"
, "--symlink-bindir=" ++ localBin
, "exe:hie"
, "--overwrite-policy=always"
]
liftIO $ do
copyFile (localBin </> "hie" <.> exe)
(localBin </> "hie-" ++ versionNumber <.> exe)
copyFile (localBin </> "hie" <.> exe)
(localBin </> "hie-" ++ dropExtension versionNumber <.> exe)
installCabal :: Action ()
installCabal = do
-- try to find existing `cabal` executable with appropriate version
cabalExe <- liftIO (findExecutable "cabal") >>= \case
Nothing -> return Nothing
Just cabalExe -> do
cabalVersion <- trimmedStdout <$> execCabal ["--numeric-version"]
whenMaybe (checkVersion requiredCabalVersion cabalVersion)
$ return cabalExe
-- install `cabal-install` if not already installed
when (isNothing cabalExe) $ execStackShake_ ["install", "cabal-install"]
-- | check `stack` has the required version
checkCabal :: Action ()
checkCabal = do
cabalVersion <- trimmedStdout <$> execCabal ["--numeric-version"]
unless (checkVersion requiredCabalVersion cabalVersion) $ do
printInStars $ cabalInstallIsOldFailMsg cabalVersion
error $ stackExeIsOldFailMsg cabalVersion
getCabalVersion :: Action String
getCabalVersion = trimmedStdout <$> execCabal ["--numeric-version"]
-- TODO: this restriction will be gone in the next release of cabal
validateCabalNewInstallIsSupported :: Action ()
validateCabalNewInstallIsSupported = when isWindowsSystem $ do
printInStars cabalInstallNotSuportedFailMsg
error cabalInstallNotSuportedFailMsg
-- | Error message when a windows system tries to install HIE via `cabal new-install`
cabalInstallNotSuportedFailMsg :: String
cabalInstallNotSuportedFailMsg =
"This system has been identified as a windows system.\n"
++ "Unfortunately, `cabal new-install` is currently not supported on windows.\n"
++ "Please 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"
-- | Error message when the `stack` binary is an older version
cabalInstallIsOldFailMsg :: String -> String
cabalInstallIsOldFailMsg cabalVersion =
"The `cabal` executable is outdated.\n"
++ "found version is `"
++ cabalVersion
++ "`.\n"
++ "required version is `"
++ versionToString requiredCabalVersion
++ "`."
requiredCabalVersion :: RequiredVersion
requiredCabalVersion = [2, 4, 1, 0]

111
install/src/Env.hs Normal file
View File

@ -0,0 +1,111 @@
module Env where
import Development.Shake
import Development.Shake.Command
import Control.Monad.IO.Class
import Control.Monad
import Development.Shake.FilePath
import System.Info ( os
, arch
)
import Data.Maybe ( isJust )
import System.Directory ( findExecutable
, findExecutables
, listDirectory
)
import Data.Function ( (&)
, on
)
import Data.List ( sort
, isInfixOf
, nubBy
)
import Control.Monad.Extra ( mapMaybeM )
import Data.Maybe ( isNothing
, mapMaybe
)
import qualified Data.Text as T
import Version
import Print
type GhcPath = String
existsExecutable :: MonadIO m => String -> m Bool
existsExecutable executable = liftIO $ isJust <$> findExecutable executable
-- | Check if the current system is windows
isWindowsSystem :: Bool
isWindowsSystem = os `elem` ["mingw32", "win32"]
findInstalledGhcs :: IO [(VersionNumber, GhcPath)]
findInstalledGhcs = do
hieVersions <- getHieVersions :: IO [VersionNumber]
knownGhcs <- mapMaybeM
(\version -> getGhcPathOf version >>= \case
Nothing -> return Nothing
Just p -> return $ Just (version, p)
)
(reverse hieVersions)
availableGhcs <- getGhcPaths
return
-- nub by version. knownGhcs takes precedence.
$ nubBy ((==) `on` fst)
-- filter out stack provided GHCs
$ filter (not . isInfixOf ".stack" . snd) (knownGhcs ++ availableGhcs)
-- | Get the path to a GHC that has the version specified by `VersionNumber`
-- If no such GHC can be found, Nothing is returned.
-- First, it is checked whether there is a GHC with the name `ghc-$VersionNumber`.
-- If this yields no result, it is checked, whether the numeric-version of the `ghc`
-- command fits to the desired version.
getGhcPathOf :: MonadIO m => VersionNumber -> m (Maybe GhcPath)
getGhcPathOf ghcVersion =
liftIO $ findExecutable ("ghc-" ++ ghcVersion) >>= \case
Nothing -> lookup ghcVersion <$> getGhcPaths
path -> return path
-- | Get a list of GHCs that are available in $PATH
getGhcPaths :: MonadIO m => m [(VersionNumber, GhcPath)]
getGhcPaths = liftIO $ do
paths <- findExecutables "ghc"
forM paths $ \path -> do
Stdout version <- cmd path ["--numeric-version"]
return (trim version, path)
-- | No suitable ghc version has been found. Show a message.
ghcVersionNotFoundFailMsg :: VersionNumber -> String
ghcVersionNotFoundFailMsg versionNumber =
"No GHC with version "
<> versionNumber
<> " has been found.\n"
<> "Either install a fitting GHC, use the stack targets or modify the PATH variable accordingly."
-- | Defines all different hie versions that are buildable.
--
-- The current directory is scanned for `stack-*.yaml` files.
-- On windows, `8.6.3` is excluded as this version of ghc does not work there
getHieVersions :: MonadIO m => m [VersionNumber]
getHieVersions = do
let stackYamlPrefix = T.pack "stack-"
let stackYamlSuffix = T.pack ".yaml"
files <- liftIO $ listDirectory "."
let hieVersions =
files
& map T.pack
& mapMaybe
(T.stripPrefix stackYamlPrefix >=> T.stripSuffix stackYamlSuffix)
& map T.unpack
-- the following line excludes `8.6.3` on windows systems
& filter (\p -> not isWindowsSystem || p /= "8.6.3")
& sort
return hieVersions
-- | Most recent version of hie.
-- Shown in the more concise help message.
mostRecentHieVersion :: MonadIO m => m VersionNumber
mostRecentHieVersion = last <$> getHieVersions

148
install/src/Help.hs Normal file
View File

@ -0,0 +1,148 @@
-- |Module for Help messages and traget descriptions
module Help where
import Development.Shake
import Data.List ( intersperse
, intercalate
)
import Env
import Print
import Version
import BuildSystem
printUsage :: Action ()
printUsage = do
printLine ""
printLine "Usage:"
printLineIndented ("stack install.hs <target>")
printLineIndented "or"
printLineIndented ("cabal new-run install.hs --project-file shake.project <target>")
-- | short help message is printed by default
shortHelpMessage :: Action ()
shortHelpMessage = do
hieVersions <- getHieVersions
printUsage
printLine ""
printLine "Targets:"
mapM_ (printLineIndented . showTarget (spaces hieVersions)) (targets hieVersions)
printLine ""
where
spaces hieVersions = space (targets hieVersions)
targets hieVersions =
[ ("help", "Show help message including all targets")
, emptyTarget
, buildTarget
, buildAllTarget
, hieTarget $ last hieVersions
, buildDataTarget
, cabalGhcsTarget
]
-- | A record that specifies for each build system which versions of @hie@ can be built.
data BuildableVersions = BuildableVersions
{ stackVersions :: [VersionNumber]
, cabalVersions :: [VersionNumber]
}
getDefaultBuildSystemVersions :: BuildableVersions -> [VersionNumber]
getDefaultBuildSystemVersions BuildableVersions {..}
| isRunFromStack = stackVersions
| isRunFromCabal = cabalVersions
| otherwise = error $ "unknown build system: " ++ buildSystem
helpMessage :: BuildableVersions -> Action ()
helpMessage versions@BuildableVersions {..} = do
printUsage
printLine ""
printLine "Targets:"
mapM_ (printLineIndented . showTarget spaces) targets
printLine ""
where
spaces = space targets
-- All targets the shake file supports
targets :: [(String, String)]
targets = intercalate
[emptyTarget]
[ generalTargets
, defaultTargets
, stackTargets
, cabalTargets
, [macosIcuTarget]
]
-- All targets with their respective help message.
generalTargets = [helpTarget]
defaultTargets = [buildTarget, buildAllTarget, buildDataTarget]
++ map hieTarget (getDefaultBuildSystemVersions versions)
stackTargets =
[ stackTarget buildTarget
, stackTarget buildAllTarget
, stackTarget buildDataTarget
]
++ map (stackTarget . hieTarget) stackVersions
cabalTargets =
[ cabalGhcsTarget
, cabalTarget buildTarget
, cabalTarget buildAllTarget
, cabalTarget buildDataTarget
]
++ map (cabalTarget . hieTarget) cabalVersions
-- | Empty target. Purpose is to introduce a newline between the targets
emptyTarget :: (String, String)
emptyTarget = ("", "")
targetWithBuildSystem :: String -> TargetDescription -> TargetDescription
targetWithBuildSystem system (target, description) =
(system ++ "-" ++ target, description ++ "; with " ++ system)
stackTarget :: TargetDescription -> TargetDescription
stackTarget = targetWithBuildSystem "stack"
cabalTarget :: TargetDescription -> TargetDescription
cabalTarget = targetWithBuildSystem "cabal"
hieTarget :: String -> TargetDescription
hieTarget version =
("hie-" ++ version, "Builds hie for GHC version " ++ version)
buildTarget :: TargetDescription
buildTarget = ("build", "Builds hie with all installed GHCs")
buildDataTarget :: TargetDescription
buildDataTarget =
("build-data", "Get the required data-files for `hie` (Hoogle DB)")
buildAllTarget :: TargetDescription
buildAllTarget =
("build-all", "Builds hie for all installed GHC versions and the data files")
-- speical targets
macosIcuTarget :: TargetDescription
macosIcuTarget = ("icu-macos-fix", "Fixes icu related problems in MacOS")
helpTarget :: TargetDescription
helpTarget = ("help", "Show help message including all targets")
cabalGhcsTarget :: TargetDescription
cabalGhcsTarget =
( "cabal-ghcs"
, "Show all GHC versions that can be installed via `cabal-build` and `cabal-build-all`."
)
-- | Creates a message of the form "a, b, c and d", where a,b,c,d are GHC versions.
-- If there is no GHC in the list of `hieVersions`
allVersionMessage :: [String] -> String
allVersionMessage wordList = case wordList of
[] -> ""
[a] -> show a
(a : as) ->
let msg = intersperse ", " wordList
lastVersion = last msg
in concat $ init (init msg) ++ [" and ", lastVersion]

147
install/src/HieInstall.hs Normal file
View File

@ -0,0 +1,147 @@
module HieInstall where
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Extra ( unlessM
, mapMaybeM
)
import Data.Maybe ( isJust )
import System.Directory ( listDirectory )
import System.Environment ( unsetEnv )
import System.Info ( os
, arch
)
import Data.Maybe ( isNothing
, mapMaybe
)
import Data.List ( dropWhileEnd
, intersperse
, intercalate
, sort
, sortOn
)
import qualified Data.Text as T
import Data.Char ( isSpace )
import Data.Version ( parseVersion
, makeVersion
, showVersion
)
import Data.Function ( (&) )
import Text.ParserCombinators.ReadP ( readP_to_S )
import BuildSystem
import Stack
import Cabal
import Version
import Print
import Env
import Help
defaultMain :: IO ()
defaultMain = do
-- unset GHC_PACKAGE_PATH for cabal
unsetEnv "GHC_PACKAGE_PATH"
-- used for cabal-based targets
ghcPaths <- findInstalledGhcs
let ghcVersions = map fst ghcPaths
-- used for stack-based targets
hieVersions <- getHieVersions
let versions = BuildableVersions { stackVersions = hieVersions
, cabalVersions = ghcVersions
}
putStrLn $ "run from: " ++ buildSystem
shakeArgs shakeOptions { shakeFiles = "_build" } $ do
want ["short-help"]
-- general purpose targets
phony "submodules" updateSubmodules
phony "cabal" installCabal
phony "short-help" shortHelpMessage
phony "all" shortHelpMessage
phony "help" (helpMessage versions)
phony "check-stack" checkStack
phony "check-cabal" checkCabal
phony "cabal-ghcs" $ do
let
msg =
"Found the following GHC paths: \n"
++ unlines
(map (\(version, path) -> "ghc-" ++ version ++ ": " ++ path)
ghcPaths
)
printInStars msg
-- default-targets
phony "build" $ need [buildSystem ++ "-build"]
phony "build-all" $ need [buildSystem ++ "-build-all"]
phony "build-data" $ need [buildSystem ++ "-build-data"]
forM_
(getDefaultBuildSystemVersions versions)
(\version ->
phony ("hie-" ++ version) $ need [buildSystem ++ "-hie-" ++ version]
)
-- stack specific targets
phony "stack-build" (need (reverse $ map ("hie-" ++) hieVersions))
phony "stack-build-all" (need ["build-data", "build"])
phony "stack-build-data" $ do
need ["submodules"]
need ["check-stack"]
stackBuildData
forM_
hieVersions
(\version -> phony ("stack-hie-" ++ version) $ do
need ["submodules"]
need ["check-stack"]
need ["cabal"]
stackBuildHie version
stackInstallHie version
)
-- cabal specific targets
phony "cabal-build" (need (map ("cabal-hie-" ++) ghcVersions))
phony "cabal-build-all" (need ["cabal-build-data", "cabal-build"])
phony "cabal-build-data" $ do
need ["submodules"]
need ["cabal"]
cabalBuildData
forM_
ghcVersions
(\version -> phony ("cabal-hie-" ++ version) $ do
validateCabalNewInstallIsSupported
need ["submodules"]
need ["cabal"]
cabalBuildHie version
cabalInstallHie version
)
-- macos specific targets
phony "icu-macos-fix"
(need ["icu-macos-fix-install"] >> need ["icu-macos-fix-build"])
phony "icu-macos-fix-install" (command_ [] "brew" ["install", "icu4c"])
phony "icu-macos-fix-build" $ mapM_ buildIcuMacosFix hieVersions
buildIcuMacosFix :: VersionNumber -> Action ()
buildIcuMacosFix version = execStackWithGhc_
version
[ "build"
, "text-icu"
, "--extra-lib-dirs=/usr/local/opt/icu4c/lib"
, "--extra-include-dirs=/usr/local/opt/icu4c/include"
]
-- | update the submodules that the project is in the state as required by the `stack.yaml` files
updateSubmodules :: Action ()
updateSubmodules = do
command_ [] "git" ["submodule", "sync"]
command_ [] "git" ["submodule", "update", "--init"]

47
install/src/Print.hs Normal file
View File

@ -0,0 +1,47 @@
module Print where
import Development.Shake
import Development.Shake.Command
import Control.Monad.IO.Class
import Data.List ( dropWhileEnd
, dropWhile
)
import Data.Char ( isSpace )
-- | lift putStrLn to MonadIO
printLine :: MonadIO m => String -> m ()
printLine = liftIO . putStrLn
-- | print a line prepended with 4 spaces
printLineIndented :: MonadIO m => String -> m ()
printLineIndented = printLine . (" " ++)
embedInStars :: String -> String
embedInStars str =
let starsLine = "\n" <> replicate 30 '*' <> "\n"
in starsLine <> str <> starsLine
printInStars :: MonadIO m => String -> m ()
printInStars = liftIO . putStrLn . embedInStars
-- | Trim whitespace of both ends of a string
trim :: String -> String
trim = dropWhileEnd isSpace . dropWhile isSpace
-- | Trim the whitespace of the stdout of a command
trimmedStdout :: Stdout String -> String
trimmedStdout (Stdout s) = trim s
type TargetDescription = (String, String)
-- | Number of spaces the target name including whitespace should have.
-- At least twenty, maybe more if target names are long. At most the length of the longest target plus five.
space :: [TargetDescription] -> Int
space phonyTargets = maximum (20 : map ((+ 5) . length . fst) phonyTargets)
-- | Show a target.
-- Concatenates the target with its help message and inserts whitespace between them.
showTarget :: Int -> TargetDescription -> String
showTarget spaces (target, msg) =
target ++ replicate (spaces - length target) ' ' ++ msg

98
install/src/Stack.hs Normal file
View File

@ -0,0 +1,98 @@
module Stack where
import Development.Shake
import Development.Shake.Command
import Development.Shake.FilePath
import Control.Monad
import System.Directory ( copyFile )
import Version
import Print
import Env
stackBuildHie :: VersionNumber -> Action ()
stackBuildHie versionNumber = execStackWithGhc_ versionNumber ["build"]
`actionOnException` liftIO (putStrLn stackBuildFailMsg)
-- | copy the built binaries into the localBinDir
stackInstallHie :: VersionNumber -> Action ()
stackInstallHie versionNumber = do
execStackWithGhc_ versionNumber ["install"]
localBinDir <- getLocalBin
let hie = "hie" <.> exe
liftIO $ do
copyFile (localBinDir </> hie)
(localBinDir </> "hie-" ++ versionNumber <.> exe)
copyFile (localBinDir </> hie)
(localBinDir </> "hie-" ++ dropExtension versionNumber <.> exe)
buildCopyCompilerTool :: VersionNumber -> Action ()
buildCopyCompilerTool versionNumber =
execStackWithGhc_ versionNumber ["build", "--copy-compiler-tool"]
-- | check `stack` has the required version
checkStack :: Action ()
checkStack = do
stackVersion <- trimmedStdout <$> execStackShake ["--numeric-version"]
unless (checkVersion requiredStackVersion stackVersion) $ do
printInStars $ stackExeIsOldFailMsg stackVersion
error $ stackExeIsOldFailMsg stackVersion
-- | Get the local binary path of stack.
-- Equal to the command `stack path --local-bin`
getLocalBin :: Action FilePath
getLocalBin = do
Stdout stackLocalDir' <- execStackShake ["path", "--local-bin"]
return $ trim stackLocalDir'
stackBuildData :: Action ()
stackBuildData = do
execStackShake_ ["build", "hoogle"]
execStackShake_ ["exec", "hoogle", "generate"]
-- | Execute a stack command for a specified ghc, discarding the output
execStackWithGhc_ :: VersionNumber -> [String] -> Action ()
execStackWithGhc_ versionNumber args = do
let stackFile = "stack-" ++ versionNumber ++ ".yaml"
command_ [] "stack" (("--stack-yaml=" ++ stackFile) : args)
-- | Execute a stack command for a specified ghc
execStackWithGhc :: CmdResult r => VersionNumber -> [String] -> Action r
execStackWithGhc versionNumber args = do
let stackFile = "stack-" ++ versionNumber ++ ".yaml"
command [] "stack" (("--stack-yaml=" ++ stackFile) : args)
-- | Execute a stack command with the same resolver as the build script
execStackShake :: CmdResult r => [String] -> Action r
execStackShake args = command [] "stack" ("--stack-yaml=install/shake.yaml" : args)
-- | Execute a stack command with the same resolver as the build script, discarding the output
execStackShake_ :: [String] -> Action ()
execStackShake_ args = command_ [] "stack" ("--stack-yaml=install/shake.yaml" : args)
-- | Error message when the `stack` binary is an older version
stackExeIsOldFailMsg :: String -> String
stackExeIsOldFailMsg stackVersion =
"The `stack` executable is outdated.\n"
++ "found version is `"
++ stackVersion
++ "`.\n"
++ "required version is `"
++ versionToString requiredStackVersion
++ "`.\n"
++ "Please run `stack upgrade` to upgrade your stack installation"
requiredStackVersion :: RequiredVersion
requiredStackVersion = [1, 9, 3]
-- |Stack build fails message
stackBuildFailMsg :: String
stackBuildFailMsg =
embedInStars
$ "Building failed, "
++ "Try running `stack clean` and restart the build\n"
++ "If this does not work, open an issue at \n"
++ "\thttps://github.com/haskell/haskell-ide-engine"

24
install/src/Version.hs Normal file
View File

@ -0,0 +1,24 @@
module Version where
import Data.Version ( Version
, parseVersion
, makeVersion
, showVersion
)
import Text.ParserCombinators.ReadP ( readP_to_S )
import Control.Monad.IO.Class
type VersionNumber = String
type RequiredVersion = [Int]
versionToString :: RequiredVersion -> String
versionToString = showVersion . makeVersion
-- | Parse a version-string into a version. Fails if the version-string is not valid
parseVersionEx :: String -> Version
parseVersionEx = fst . head . filter (("" ==) . snd) . readP_to_S parseVersion
-- | Check that a given version-string is not smaller than the required version
checkVersion :: RequiredVersion -> String -> Bool
checkVersion required given = parseVersionEx given >= makeVersion required

2
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 docUri)
docVersion <- fmap _version <$> liftIO (vfsFunc (J.toNormalizedUri docUri))
let docId = J.VersionedTextDocumentIdentifier docUri docVersion
let getProvider p = pluginCodeActionProvider p <*> return (pluginId p)

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

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
@ -25,7 +26,11 @@ import Haskell.Ide.Engine.PluginUtils
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))
import Language.Haskell.HLint4 as Hlint
#else
import Language.Haskell.HLint3 as Hlint
#endif
import qualified Language.Haskell.LSP.Types as LSP
import qualified Language.Haskell.LSP.Types.Lens as LSP
import Refact.Apply

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

@ -15,6 +15,7 @@ import Data.Maybe
import Data.Semigroup
#endif
import qualified Data.Text as T
import qualified Data.Versions as V
import Development.GitRev (gitCommitCount)
import Distribution.System (buildArch)
import Distribution.Text (display)
@ -126,14 +127,34 @@ getProjectGhcVersion = do
then tryCommand "ghc --numeric-version"
else return "No System GHC found"
tryCommand cmd =
init <$> readCreateProcess (shell cmd) ""
tryCommand :: String -> IO String
tryCommand cmd =
init <$> readCreateProcess (shell cmd) ""
hieGhcVersion :: String
hieGhcVersion = VERSION_ghc
-- ---------------------------------------------------------------------
getStackVersion :: IO (Maybe V.Version)
getStackVersion = do
isStackInstalled <- isJust <$> findExecutable "stack"
if isStackInstalled
then do
versionStr <- tryCommand "stack --numeric-version"
case V.version (T.pack versionStr) of
Left _err -> return Nothing
Right v -> return (Just v)
else return Nothing
stack193Version :: V.Version
stack193Version = case V.version "1.9.3" of
Left err -> error $ "stack193Version:err=" ++ show err
Right v -> v
-- ---------------------------------------------------------------------
checkCabalInstall :: IO Bool
checkCabalInstall = isJust <$> findExecutable "cabal"

83
src/Haskell/Ide/Engine/Plugin/Hoogle.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskell.Ide.Engine.Plugin.Hoogle where
@ -5,6 +7,7 @@ module Haskell.Ide.Engine.Plugin.Hoogle where
import Control.Monad.IO.Class
import Control.Monad (join)
import Control.Exception
import Control.Applicative (liftA2)
import Data.Aeson
import Data.Bifunctor
import Data.Maybe
@ -44,10 +47,10 @@ hoogleDescriptor plId = PluginDescriptor
-- ---------------------------------------------------------------------
data HoogleError
data HoogleError
= NoDb
| DbFail T.Text
| NoResults
| NoResults
deriving (Eq,Ord,Show)
newtype HoogleDb = HoogleDb (Maybe FilePath)
@ -97,11 +100,16 @@ infoCmd = CmdSync $ \expr -> do
infoCmd' :: T.Text -> IdeM (Either HoogleError T.Text)
infoCmd' expr = do
HoogleDb mdb <- get
liftIO $ runHoogleQuery mdb expr $ \res ->
if null res then
Left NoResults
else
return $ T.pack $ targetInfo $ head res
liftIO $ runHoogleQuery mdb expr $ \case
[] -> Left NoResults
h:_ -> return $ renderTargetInfo h
renderTargetInfo :: Target -> T.Text
renderTargetInfo t =
T.intercalate "\n"
$ ["```haskell\n" <> unHTML (T.pack $ targetItem t) <> "\n```"]
++ [renderDocs $ targetDocs t]
++ [T.pack $ curry annotate "More info" $ targetURL t]
-- | Command to get the prettified documentation of an hoogle identifier.
-- Identifier should be understandable for hoogle.
@ -115,11 +123,9 @@ infoCmd' expr = do
infoCmdFancyRender :: T.Text -> IdeM (Either HoogleError T.Text)
infoCmdFancyRender expr = do
HoogleDb mdb <- get
liftIO $ runHoogleQuery mdb expr $ \res ->
if null res then
Left NoResults
else
return $ renderTarget $ head res
liftIO $ runHoogleQuery mdb expr $ \case
[] -> Left NoResults
h:_ -> return $ renderTarget h
-- | Render the target in valid markdown.
-- Transform haddock documentation into markdown.
@ -131,18 +137,29 @@ renderTarget t = T.intercalate "\n" $
++ [renderDocs $ targetDocs t]
++ [T.pack $ curry annotate "More info" $ targetURL t]
where mdl = map annotate $ catMaybes [targetPackage t, targetModule t]
annotate (thing,url) = "["<>thing++"]"++"("++url++")"
unHTML = T.replace "<0>" "" . innerText . parseTags
renderDocs = T.concat . map htmlToMarkDown . parseTree . T.pack
htmlToMarkDown :: TagTree T.Text -> T.Text
htmlToMarkDown (TagLeaf x) = fromMaybe "" $ maybeTagText x
htmlToMarkDown (TagBranch "i" _ tree) = "*" <> T.concat (map htmlToMarkDown tree) <> "*"
htmlToMarkDown (TagBranch "b" _ tree) = "**" <> T.concat (map htmlToMarkDown tree) <> "**"
htmlToMarkDown (TagBranch "a" _ tree) = "`" <> T.concat (map htmlToMarkDown tree) <> "`"
htmlToMarkDown (TagBranch "li" _ tree) = "- " <> T.concat (map htmlToMarkDown tree)
htmlToMarkDown (TagBranch "tt" _ tree) = "`" <> innerText (flattenTree tree) <> "`"
htmlToMarkDown (TagBranch "pre" _ tree) = "```haskell\n" <> T.concat (map htmlToMarkDown tree) <> "```"
htmlToMarkDown (TagBranch _ _ tree) = T.concat $ map htmlToMarkDown tree
annotate :: (String, String) -> String
annotate (thing,url) = "["<>thing<>"]"<>"("<>url<>")"
-- | Hoogle results contain html like tags.
-- We remove them with `tagsoup` here.
-- So, if something hoogle related shows html tags,
-- then maybe this function is responsible.
unHTML :: T.Text -> T.Text
unHTML = T.replace "<0>" "" . innerText . parseTags
renderDocs :: String -> T.Text
renderDocs = T.concat . map htmlToMarkDown . parseTree . T.pack
htmlToMarkDown :: TagTree T.Text -> T.Text
htmlToMarkDown (TagLeaf x) = fromMaybe "" $ maybeTagText x
htmlToMarkDown (TagBranch "i" _ tree) = "*" <> T.concat (map htmlToMarkDown tree) <> "*"
htmlToMarkDown (TagBranch "b" _ tree) = "**" <> T.concat (map htmlToMarkDown tree) <> "**"
htmlToMarkDown (TagBranch "a" _ tree) = "`" <> T.concat (map htmlToMarkDown tree) <> "`"
htmlToMarkDown (TagBranch "li" _ tree) = "- " <> T.concat (map htmlToMarkDown tree)
htmlToMarkDown (TagBranch "tt" _ tree) = "`" <> innerText (flattenTree tree) <> "`"
htmlToMarkDown (TagBranch "pre" _ tree) = "```haskell\n" <> T.concat (map htmlToMarkDown tree) <> "```"
htmlToMarkDown (TagBranch _ _ tree) = T.concat $ map htmlToMarkDown tree
------------------------------------------------------------------------
@ -152,7 +169,21 @@ renderTarget t = T.intercalate "\n" $
-- If an error occurs, such as no hoogle database has been found,
-- or the search term has no match, an empty list will be returned.
searchModules :: T.Text -> IdeM [T.Text]
searchModules = fmap (nub . take 5) . searchTargets (fmap (T.pack . fst) . targetModule)
searchModules = fmap (map fst) . searchModules'
-- | Just like 'searchModules', but includes the signature of the search term
-- that has been found in the module.
searchModules' :: T.Text -> IdeM [(T.Text, T.Text)]
searchModules' = fmap (take 5 . nub) . searchTargets retrieveModuleAndSignature
where
retrieveModuleAndSignature :: Target -> Maybe (T.Text, T.Text)
retrieveModuleAndSignature target = liftA2 (,) (packModuleName target) (packSymbolSignature target)
packModuleName :: Target -> Maybe T.Text
packModuleName = fmap (T.pack . fst) . targetModule
packSymbolSignature :: Target -> Maybe T.Text
packSymbolSignature = Just . unHTML . T.pack . targetItem
-- | Search for packages that satisfy the given search text.
-- Will return at most five, unique results.
@ -160,7 +191,7 @@ searchModules = fmap (nub . take 5) . searchTargets (fmap (T.pack . fst) . targe
-- If an error occurs, such as no hoogle database has been found,
-- or the search term has no match, an empty list will be returned.
searchPackages :: T.Text -> IdeM [T.Text]
searchPackages = fmap (nub . take 5) . searchTargets (fmap (T.pack . fst) . targetPackage)
searchPackages = fmap (take 5 . nub) . searchTargets (fmap (T.pack . fst) . targetPackage)
-- | Search for Targets that fit to the given Text and satisfy the given predicate.
-- Limits the amount of matches to at most ten.

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

@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module Haskell.Ide.Engine.Plugin.HsImport where
@ -9,8 +8,6 @@ import Control.Lens.Operators
import Control.Monad.IO.Class
import Control.Monad
import Data.Aeson
import Data.Bitraversable
import Data.Bifunctor
import Data.Foldable
import Data.Maybe
import Data.Monoid ( (<>) )
@ -28,6 +25,7 @@ import qualified Haskell.Ide.Engine.Plugin.Hoogle
as Hoogle
import System.Directory
import System.IO
import qualified Safe as S
hsimportDescriptor :: PluginId -> PluginDescriptor
hsimportDescriptor plId = PluginDescriptor
@ -42,19 +40,82 @@ hsimportDescriptor plId = PluginDescriptor
, pluginFormattingProvider = Nothing
}
-- | Type of the symbol to import.
-- Important to offer the correct import list, or hiding code action.
data SymbolType
= Symbol -- ^ Symbol is a simple function
| Constructor -- ^ Symbol is a constructor
| Type -- ^ Symbol is a type
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
-- | What of the symbol should be taken.
-- Import a simple symbol, or a value constructor.
data SymbolKind
= Only SymbolName -- ^ Only the symbol should be taken
| OneOf DatatypeName SymbolName -- ^ Some constructors or methods of the symbol should be taken: Symbol(X)
| AllOf DatatypeName -- ^ All constructors or methods of the symbol should be taken: Symbol(..)
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
-- | Disambiguates between an import action and an hiding action.
-- Can be used to determine suggestion tpye from ghc-mod,
-- e.g. whether ghc-mod suggests to hide an identifier or to import an identifier.
-- Also important later, to know how the symbol shall be imported.
data SymbolImport a
= Import a -- ^ the symbol to import
| Hiding a -- ^ the symbol to hide from the import
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
-- | Utility to retrieve the contents of the 'SymbolImport'.
-- May never fail.
extractSymbolImport :: SymbolImport a -> a
extractSymbolImport (Hiding s) = s
extractSymbolImport (Import s) = s
type ModuleName = T.Text
type SymbolName = T.Text
type DatatypeName = T.Text
-- | Wrapper for a FilePath that is used as an Input file for HsImport
newtype InputFilePath = MkInputFilePath { getInput :: FilePath }
-- | Wrapper for a FilePath that is used as an Output file for HsImport
newtype OutputFilePath = MkOutputFilePath { getOutput :: FilePath }
-- | How to import a module.
-- Can be used to express to import a whole module or only specific symbols
-- from a module.
-- Is used to either hide symbols from an import or use an import-list to
-- import only a specific symbol.
data ImportStyle
= Simple -- ^ Import the whole module
| Complex (SymbolImport SymbolKind) -- ^ Complex operation, import module hiding symbols or import only selected symbols.
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
-- | Contains information about the diagnostic, the symbol ghc-mod
-- complained about and what the kind of the symbol is and whether
-- to import or hide the symbol as suggested by ghc-mod.
data ImportDiagnostic = ImportDiagnostic
{ diagnostic :: J.Diagnostic
, term :: SymbolName
, termType :: SymbolImport SymbolType
}
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
-- | Import Parameters for Modules.
-- Can be used to import every symbol from a module,
-- or to import only a specific function from a module.
data ImportParams = ImportParams
{ file :: Uri -- ^ Uri to the file to import the module to.
, addToImportList :: Maybe T.Text -- ^ If set, an import-list will be created.
, moduleToImport :: T.Text -- ^ Name of the module to import.
{ file :: Uri -- ^ Uri to the file to import the module to.
, importStyle :: ImportStyle -- ^ How to import the module
, moduleToImport :: ModuleName -- ^ Name of the module to import.
}
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
importCmd :: CommandFunc ImportParams J.WorkspaceEdit
importCmd = CmdSync $ \(ImportParams uri importList modName) ->
importModule uri importList modName
importCmd = CmdSync $ \(ImportParams uri style modName) ->
importModule uri style modName
-- | Import the given module for the given file.
-- May take an explicit function name to perform an import-list import.
@ -62,8 +123,8 @@ importCmd = CmdSync $ \(ImportParams uri importList modName) ->
-- e.g. two consecutive imports for the same module will result in a single
-- import line.
importModule
:: Uri -> Maybe T.Text -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit)
importModule uri importList modName =
:: Uri -> ImportStyle -> ModuleName -> IdeGhcM (IdeResult J.WorkspaceEdit)
importModule uri impStyle modName =
pluginGetFile "hsimport cmd: " uri $ \origInput -> do
shouldFormat <- formatOnImportOn <$> getConfig
@ -74,13 +135,13 @@ importModule uri importList modName =
tmpDir <- liftIO getTemporaryDirectory
(output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput"
liftIO $ hClose outputH
let args = defaultArgs { moduleName = T.unpack modName
, inputSrcFile = input
, symbolName = T.unpack $ fromMaybe "" importList
, outputSrcFile = output
}
let args = importStyleToHsImportArgs
(MkInputFilePath input)
(MkOutputFilePath output)
modName
impStyle
-- execute hsimport on the given file and write into a temporary file.
maybeErr <- liftIO $ hsimportWithArgs defaultConfig args
maybeErr <- liftIO $ HsImport.hsimportWithArgs HsImport.defaultConfig args
case maybeErr of
Just err -> do
liftIO $ removeFile output
@ -154,6 +215,49 @@ importModule uri importList modName =
$ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges)
else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
-- | Convert the import style arguments into HsImport arguments.
-- Takes an input and an output file as well as a module name.
importStyleToHsImportArgs
:: InputFilePath -> OutputFilePath -> ModuleName -> ImportStyle -> HsImport.HsImportArgs
importStyleToHsImportArgs input output modName style =
let defaultArgs = -- Default args, must be set every time.
HsImport.defaultArgs { HsImport.moduleName = T.unpack modName
, HsImport.inputSrcFile = getInput input
, HsImport.outputSrcFile = getOutput output
}
-- | Remove parenthesis for operators and infix operator cosntructors.
-- HsImport demands it. E.g.
-- > hsimport -m Data.Array.Repa -s :. -w :.
-- import Data.Array.Repa ((:.)((:.)))
--
-- > hsimport -m Data.Function -s $
-- import Data.Function (($))
trimParenthesis :: T.Text -> T.Text
trimParenthesis = T.dropAround isParenthesis
isParenthesis = (`elem` ['(', ')'])
kindToArgs :: SymbolKind -> HsImport.HsImportArgs
kindToArgs kind = case kind of
-- Only import a single symbol e.g. Data.Text (isPrefixOf)
Only sym -> defaultArgs { HsImport.symbolName = T.unpack $ trimParenthesis sym }
-- Import a constructor e.g. Data.Mabye (Maybe(Just))
OneOf dt sym -> defaultArgs { HsImport.symbolName = T.unpack $ trimParenthesis dt
, HsImport.with = [T.unpack $ trimParenthesis sym]
}
-- Import all constructors e.g. Data.Maybe (Maybe(..))
AllOf dt -> defaultArgs { HsImport.symbolName = T.unpack $ trimParenthesis dt
, HsImport.all = True
}
in case style of
-- If the import style is simple, import thw whole module
Simple -> defaultArgs
Complex s -> case s of
Hiding kind -> kindToArgs kind {- TODO: wait for hsimport version bump -}
Import kind -> kindToArgs kind
-- | Search style for Hoogle.
-- Can be used to look either for the exact term,
-- only the exact name or a relaxed form of the term.
@ -189,31 +293,26 @@ codeActionProvider plId docId _ context = do
--
-- Result may produce several import actions, or none.
importActionsForTerms
:: SearchStyle -> [(J.Diagnostic, T.Text)] -> IdeM [J.CodeAction]
importActionsForTerms style terms = do
let searchTerms = map (bimap id (applySearchStyle style)) terms
-- Get the function names for a nice import-list title.
let functionNames = map (head . T.words . snd) terms
searchResults' <- mapM (bimapM return Hoogle.searchModules) searchTerms
let searchResults = zip functionNames searchResults'
let normalise =
concatMap (\(a, b) -> zip (repeat a) (concatTerms b)) searchResults
concat <$> mapM (uncurry (termToActions style)) normalise
:: SearchStyle -> [ImportDiagnostic] -> IdeM [J.CodeAction]
importActionsForTerms style importDiagnostics = do
let searchTerms = map (applySearchStyle style . term) importDiagnostics
searchResults <- mapM Hoogle.searchModules' searchTerms
let importTerms = zip searchResults importDiagnostics
concat <$> mapM (uncurry (termToActions style)) importTerms
-- | Apply the search style to given term.
-- Can be used to look for a term that matches exactly the search term,
-- or one that matches only the exact name.
-- At last, a custom relaxation function can be passed for more control.
applySearchStyle :: SearchStyle -> T.Text -> T.Text
applySearchStyle Exact term = "is:exact " <> term
applySearchStyle ExactName term = case T.words term of
[] -> term
applySearchStyle Exact termName = "is:exact " <> termName
applySearchStyle ExactName termName = case T.words termName of
[] -> termName
(x : _) -> "is:exact " <> x
applySearchStyle (Relax relax) term = relax term
applySearchStyle (Relax relax) termName = relax termName
-- | Turn a search term with function name into Import Actions.
-- Function name may be of only the exact phrase to import.
-- | Turn a search term with function name into an Import Actions.
-- The function name may be of only the exact phrase to import.
-- The resulting CodeAction's contain a general import of a module or
-- uses an Import-List.
--
@ -225,61 +324,177 @@ codeActionProvider plId docId _ context = do
-- no import list can be offered, since the function name
-- may be not the one we expect.
termToActions
:: SearchStyle -> T.Text -> (J.Diagnostic, T.Text) -> IdeM [J.CodeAction]
termToActions style functionName (diagnostic, termName) = do
let useImportList = case style of
Relax _ -> Nothing
_ -> Just (mkImportAction (Just functionName) diagnostic termName)
catMaybes <$> sequenceA
(mkImportAction Nothing diagnostic termName : maybeToList useImportList)
:: SearchStyle -> [(ModuleName, SymbolName)] -> ImportDiagnostic -> IdeM [J.CodeAction]
termToActions style modules impDiagnostic =
concat <$> mapM (uncurry (importModuleAction style impDiagnostic)) modules
-- | Creates various import actions for a module and the diagnostic.
-- Possible import actions depend on the type of the symbol to import.
-- It may be a 'Constructor', so the import actions need to be different
-- to a simple function symbol.
-- Thus, it may return zero, one or multiple import actions for a module.
-- List of import actions does contain no duplicates.
importModuleAction
:: SearchStyle -> ImportDiagnostic -> ModuleName -> SymbolName -> IdeM [J.CodeAction]
importModuleAction searchStyle impDiagnostic moduleName symbolTerm =
catMaybes <$> sequenceA codeActions
where
importListActions :: [IdeM (Maybe J.CodeAction)]
importListActions = case searchStyle of
-- If the search has been relaxed by a custom function,
-- we cant know how much the search query has been altered
-- and how close the result terms are to the initial diagnostic.
-- Thus, we cant offer more specific imports.
Relax _ -> []
_ -> catMaybes
$ case extractSymbolImport $ termType impDiagnostic of
-- If the term to import is a simple symbol, such as a function,
-- import only this function
Symbol
-> [ mkImportAction moduleName impDiagnostic . Just . Only
<$> symName symbolTerm
]
-- Constructors can be imported in two ways, either all
-- constructors of a type or only a subset.
-- We can only import a single constructor at a time though.
Constructor
-> [ mkImportAction moduleName impDiagnostic . Just . AllOf
<$> datatypeName symbolTerm
, (\dt sym -> mkImportAction moduleName impDiagnostic . Just
$ OneOf dt sym)
<$> datatypeName symbolTerm
<*> symName symbolTerm
]
-- If we are looking for a type, import it as just a symbol
Type
-> [ mkImportAction moduleName impDiagnostic . Just . Only
<$> symName symbolTerm]
-- | All code actions that may be available
-- Currently, omits all
codeActions :: [IdeM (Maybe J.CodeAction)]
codeActions = case termType impDiagnostic of
Hiding _ -> [] {- If we are hiding an import, we can not import
a module hiding everything from it. -}
Import _ -> [mkImportAction moduleName impDiagnostic Nothing]
-- ^ Simple import, import the whole module
++ importListActions
-- | Retrieve the function signature of a term such as
-- >>> signatureOf "take :: Int -> [a] -> [a]"
-- Just " Int -> [a] -> [a]"
signatureOf :: T.Text -> Maybe T.Text
signatureOf sig = do
let parts = T.splitOn "::" sig
typeSig <- S.tailMay parts
S.headMay typeSig
-- | Retrieve the datatype name of a Constructor.
--
-- >>> datatypeName "Null :: Data.Aeson.Internal.Types.Value"
-- Just "Value"
--
-- >>> datatypeName "take :: Int -> [a] -> [a]" -- Not a constructor
-- Just "[a]"
--
-- >>> datatypeName "Just :: a -> Maybe a"
-- Just "Maybe"
--
-- Thus, the result of this function only makes sense,
-- if the symbol kind of the diagnostic term is of type 'Constructor'
datatypeName :: T.Text -> Maybe T.Text
datatypeName sig = do
sig_ <- signatureOf sig
let sigParts = T.splitOn "->" sig_
lastPart <- S.lastMay sigParts
let dtNameSig = T.words lastPart
qualifiedDtName <- S.headMay dtNameSig
let qualifiedDtNameParts = T.splitOn "." qualifiedDtName
S.lastMay qualifiedDtNameParts
-- | Name of a symbol. May contain a function signature.
--
-- >>> symName "take :: Int -> [a] -> [a]"
-- Just "take"
--
-- >>> symName "take"
-- Just "take"
symName :: T.Text -> Maybe SymbolName
symName = S.headMay . T.words
concatTerms :: (a, [b]) -> [(a, b)]
concatTerms (a, b) = zip (repeat a) b
--TODO: Check if package is already installed
mkImportAction
:: Maybe T.Text -> J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction)
mkImportAction importList diag modName = do
:: ModuleName -> ImportDiagnostic -> Maybe SymbolKind -> IdeM (Maybe J.CodeAction)
mkImportAction modName importDiagnostic symbolType = do
cmd <- mkLspCommand plId "import" title (Just cmdParams)
return (Just (codeAction cmd))
where
where
codeAction cmd = J.CodeAction title
(Just J.CodeActionQuickFix)
(Just (J.List [diag]))
(Just (J.List [diagnostic importDiagnostic]))
Nothing
(Just cmd)
title =
"Import module "
<> modName
<> maybe "" (\name -> " (" <> name <> ")") importList
cmdParams = [toJSON (ImportParams (docId ^. J.uri) importList modName)]
title = "Import module "
<> modName
<> case termType importDiagnostic of
Hiding _ -> "hiding"
-- ^ Note, that it must never happen
-- in combination with `symbolType == Nothing`
Import _ -> ""
<> case symbolType of
Just s -> case s of
Only sym -> " (" <> sym <> ")"
AllOf dt -> " (" <> dt <> " (..))"
OneOf dt sym -> " (" <> dt <> " (" <> sym <> "))"
Nothing -> ""
importStyleParam :: ImportStyle
importStyleParam = case symbolType of
Nothing -> Simple
Just k -> case termType importDiagnostic of
Hiding _ -> Complex (Hiding k)
Import _ -> Complex (Import k)
cmdParams = [toJSON (ImportParams (docId ^. J.uri) importStyleParam modName)]
-- | For a Diagnostic, get an associated function name.
-- If Ghc-Mod can not find any candidates, Nothing is returned.
getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
getImportables :: J.Diagnostic -> Maybe ImportDiagnostic
getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
(diag, ) <$> extractImportableTerm msg
uncurry (ImportDiagnostic diag) <$> extractImportableTerm msg
getImportables _ = Nothing
-- | Extract from an error message an appropriate term to search for.
-- This looks at the error message and tries to extract the expected
-- signature of an unknown function.
-- If this is not possible, Nothing is returned.
extractImportableTerm :: T.Text -> Maybe T.Text
extractImportableTerm dirtyMsg = T.strip <$> asum
[ T.stripPrefix "Variable not in scope: " msg
, T.init <$> T.stripPrefix "Not in scope: type constructor or class ‘" msg
, T.stripPrefix "Data constructor not in scope: " msg
]
where
msg =
head
-- Get rid of the rename suggestion parts
extractImportableTerm :: T.Text -> Maybe (T.Text, SymbolImport SymbolType)
extractImportableTerm dirtyMsg = do
(n, s) <- extractedTerm
let n' = T.strip n
return (n', s)
where
importMsg = S.headMay
-- Get rid of the rename suggestion parts
$ T.splitOn "Perhaps you meant "
$ T.replace "\n" " "
-- Get rid of trailing/leading whitespace on each individual line
-- Get rid of trailing/leading whitespace on each individual line
$ T.unlines
$ map T.strip
$ T.lines
$ T.replace "• " "" dirtyMsg
extractedTerm = asum
[ importMsg
>>= T.stripPrefix "Variable not in scope: "
>>= \name -> Just (name, Import Symbol)
, importMsg
>>= T.stripPrefix "Not in scope: type constructor or class ‘"
>>= \name -> Just (T.init name, Import Type)
, importMsg
>>= T.stripPrefix "Data constructor not in scope: "
>>= \name -> Just (name, Import Constructor)]

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

@ -156,7 +156,7 @@ generateDiagnosics cb uri file = do
-- ---------------------------------------------------------------------
-- Find and run the liquid haskell executable
-- | Find and run the liquid haskell executable
runLiquidHaskell :: FilePath -> IO (Maybe (ExitCode,[String]))
runLiquidHaskell fp = do
mexe <- findExecutable "liquid"
@ -168,13 +168,14 @@ runLiquidHaskell fp = do
let cmd = lh ++ " --json \"" ++ fp ++ "\""
dir = takeDirectory fp
cp = (shell cmd) { cwd = Just dir }
logm $ "runLiquidHaskell:cmd=[" ++ cmd ++ "]"
-- logm $ "runLiquidHaskell:cmd=[" ++ cmd ++ "]"
mpp <- lookupEnv "GHC_PACKAGE_PATH"
-- logm $ "runLiquidHaskell:mpp=[" ++ show mpp ++ "]"
(ec,o,e) <- bracket
(unsetEnv "GHC_PACKAGE_PATH")
(\_ -> mapM_ (setEnv "GHC_PACKAGE_PATH") mpp)
(\_ -> readCreateProcessWithExitCode cp "")
logm $ "runLiquidHaskell:v=" ++ show (ec,o,e)
-- logm $ "runLiquidHaskell:v=" ++ show (ec,o,e)
return $ Just (ec,[o,e])
-- ---------------------------------------------------------------------

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

@ -96,13 +96,16 @@ data CompItem = CI
, importedFrom :: T.Text
, thingType :: Maybe Type
, label :: T.Text
, isInfix :: Maybe Backtick
}
data Backtick = Surrounded | LeftSide
instance Eq CompItem where
(CI n1 _ _ _) == (CI n2 _ _ _) = n1 == n2
ci1 == ci2 = origName ci1 == origName ci2
instance Ord CompItem where
compare (CI n1 _ _ _) (CI n2 _ _ _) = compare n1 n2
compare ci1 ci2 = origName ci1 `compare` origName ci2
occNameToComKind :: OccName -> J.CompletionItemKind
occNameToComKind oc
@ -118,16 +121,21 @@ mkQuery name importedFrom = name <> " module:" <> importedFrom
<> " is:exact"
mkCompl :: CompItem -> J.CompletionItem
mkCompl CI{origName,importedFrom,thingType,label} =
mkCompl CI{origName,importedFrom,thingType,label,isInfix} =
J.CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet)
Nothing Nothing Nothing Nothing hoogleQuery
where kind = Just $ occNameToComKind $ occName origName
hoogleQuery = Just $ toJSON $ mkQuery label importedFrom
argTypes = maybe [] getArgs thingType
insertText
| [] <- argTypes = label
| otherwise = label <> " " <> argText
insertText = case isInfix of
Nothing -> case argTypes of
[] -> label
_ -> label <> " " <> argText
Just LeftSide -> label <> "`"
Just Surrounded -> label
argText :: T.Text
argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
stripForall t
@ -217,17 +225,20 @@ instance ModuleCache CachedCompletions where
typeEnv = md_types $ snd $ tm_internals_ tm
toplevelVars = mapMaybe safeTyThingId $ typeEnvElts typeEnv
varToCompl var = CI name (showModName curMod) typ label
varToCompl :: Var -> CompItem
varToCompl var = CI name (showModName curMod) typ label Nothing
where
typ = Just $ varType var
name = Var.varName var
label = T.pack $ showGhc name
toplevelCompls :: [CompItem]
toplevelCompls = map varToCompl toplevelVars
toCompItem :: ModuleName -> Name -> CompItem
toCompItem mn n =
CI n (showModName mn) Nothing (T.pack $ showGhc n)
CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing
allImportsInfo :: [(Bool, T.Text, ModuleName, Maybe (Bool, [Name]))]
allImportsInfo = map getImpInfo importDeclerations
@ -363,6 +374,26 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) =
d = T.length fullLine - T.length (stripTypeStuff partialLine)
in Position l (c - d)
hasTrailingBacktick =
if T.length fullLine <= trailingBacktickIndex
then False
else (fullLine `T.index` trailingBacktickIndex) == '`'
trailingBacktickIndex = let Position _ cursorColumn = VFS.cursorPos prefixInfo in cursorColumn
isUsedAsInfix = if backtickIndex < 0
then False
else (fullLine `T.index` backtickIndex) == '`'
backtickIndex =
let Position _ cursorColumn = VFS.cursorPos prefixInfo
prefixLength = T.length prefixText
moduleLength = if prefixModule == ""
then 0
else T.length prefixModule + 1 {- Because of "." -}
in
cursorColumn - (prefixLength + moduleLength) - 1 {- Points to the first letter of either the module or prefix text -}
filtModNameCompls =
map mkModCompl
$ mapMaybe (T.stripPrefix enteredQual)
@ -372,13 +403,23 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) =
where
isTypeCompl = isTcOcc . occName . origName
-- completions specific to the current context
ctxCompls = case context of
ctxCompls' = case context of
TypeContext -> filter isTypeCompl compls
ValueContext -> filter (not . isTypeCompl) compls
-- Add whether the text to insert has backticks
ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
infixCompls :: Maybe Backtick
infixCompls = case (isUsedAsInfix, hasTrailingBacktick) of
(True, False) -> Just LeftSide
(True, True) -> Just Surrounded
_ -> Nothing
compls = if T.null prefixModule
then unqualCompls
else Map.findWithDefault [] prefixModule qualCompls
mkImportCompl label = (J.detail ?~ label) . mkModCompl $ fromMaybe
""
(T.stripPrefix enteredQual label)

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

@ -102,7 +102,7 @@ data DiagnosticsRequest = DiagnosticsRequest
, trackingNumber :: TrackingNumber
-- ^ The tracking identifier for this request
, file :: J.Uri
, file :: Uri
-- ^ The file that was change and needs to be checked
, documentVersion :: J.TextDocumentVersion
@ -127,7 +127,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
rin <- atomically newTChan :: IO (TChan ReactorInput)
commandIds <- allLspCmdIds plugins
let dp lf = do
let onStartup lf = do
diagIn <- atomically newTChan
let react = runReactor lf scheduler diagnosticProviders hps sps fps plugins
reactorFunc = react $ reactor rin diagIn
@ -184,8 +184,11 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
fps :: Map.Map PluginId FormattingProvider
fps = Map.mapMaybe pluginFormattingProvider $ ipMap plugins
initCallbacks :: Core.InitializeCallbacks Config
initCallbacks = Core.InitializeCallbacks getInitialConfig getConfigFromNotification onStartup
flip E.finally finalProc $ do
CTRL.run (getConfigFromNotification, dp) (hieHandlers rin) (hieOptions commandIds) captureFp
CTRL.run initCallbacks (hieHandlers rin) (hieOptions commandIds) captureFp
where
handlers = [E.Handler ioExcept, E.Handler someExcept]
finalProc = L.removeAllHandlers
@ -208,7 +211,7 @@ configVal field = field <$> getClientConfig
getPrefixAtPos :: (MonadIO m, MonadReader REnv m)
=> Uri -> Position -> m (Maybe Hie.PosPrefixInfo)
getPrefixAtPos uri pos = do
mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure uri
mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure (J.toNormalizedUri uri)
case mvf of
Just vf -> VFS.getCompletionPrefix pos vf
Nothing -> return Nothing
@ -222,7 +225,13 @@ mapFileFromVfs :: (MonadIO m, MonadReader REnv m)
mapFileFromVfs tn vtdi = do
let uri = vtdi ^. J.uri
ver = fromMaybe 0 (vtdi ^. J.version)
req = GReq tn (Just uri) Nothing Nothing (const $ return ())
vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
mvf <- liftIO $ vfsFunc (J.toNormalizedUri uri)
case (mvf, uriToFilePath uri) of
(Just (VFS.VirtualFile _ yitext _), Just fp) -> do
let text' = Rope.toString yitext
-- text = "{-# LINE 1 \"" ++ fp ++ "\"#-}\n" <> text'
let req = GReq tn (Just uri) Nothing Nothing (const $ return ())
$ IdeResultOk <$> do
persistVirtualFile uri
updateDocumentRequest uri ver req
@ -308,7 +317,7 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file
-- ---------------------------------------------------------------------
publishDiagnostics :: (MonadIO m, MonadReader REnv m)
=> Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> m ()
=> Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m ()
publishDiagnostics maxToSend uri' mv diags = do
lf <- asks lspFuncs
liftIO $ Core.publishDiagnosticsFunc lf maxToSend uri' mv diags
@ -798,7 +807,7 @@ reactor inp diagIn = do
withDocumentContents :: J.LspId -> J.Uri -> (T.Text -> R ()) -> R ()
withDocumentContents reqId uri f = do
vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
mvf <- liftIO $ vfsFunc uri
mvf <- liftIO $ vfsFunc (J.toNormalizedUri uri)
lf <- asks lspFuncs
case mvf of
Nothing -> liftIO $
@ -839,7 +848,7 @@ queueDiagnosticsRequest
:: TChan DiagnosticsRequest -- ^ The channel to publish the diagnostics requests to
-> DiagnosticTrigger
-> TrackingNumber
-> J.Uri
-> Uri
-> J.TextDocumentVersion
-> R ()
queueDiagnosticsRequest diagIn dt tn uri mVer =
@ -870,11 +879,11 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
maxToSend = maxNumberOfProblems clientConfig
sendOne (fileUri,ds') = do
debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
publishDiagnosticsIO maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
publishDiagnosticsIO maxToSend (J.toNormalizedUri fileUri) Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
sendEmpty = do
debugm "LspStdio.sendempty"
publishDiagnosticsIO maxToSend file Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
publishDiagnosticsIO maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
-- fv = case documentVersion of
-- Nothing -> Nothing
@ -902,7 +911,7 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
when enabled $ makeRequest reql
-- | get hlint and GHC diagnostics and loads the typechecked module into the cache
requestDiagnosticsNormal :: TrackingNumber -> J.Uri -> J.TextDocumentVersion -> R ()
requestDiagnosticsNormal :: TrackingNumber -> Uri -> J.TextDocumentVersion -> R ()
requestDiagnosticsNormal tn file mVer = do
clientConfig <- getClientConfig
let
@ -910,18 +919,20 @@ requestDiagnosticsNormal tn file mVer = do
-- | If there is a GHC error, flush the hlint diagnostics
-- TODO: Just flush the parse error diagnostics
sendOneGhc :: J.DiagnosticSource -> (Uri, [Diagnostic]) -> R ()
sendOneGhc :: J.DiagnosticSource -> (J.NormalizedUri, [Diagnostic]) -> R ()
sendOneGhc pid (fileUri,ds) = do
if any (hasSeverity J.DsError) ds
then publishDiagnostics maxToSend fileUri Nothing
(Map.fromList [(Just "hlint",SL.toSortedList []),(Just pid,SL.toSortedList ds)])
else sendOne pid (fileUri,ds)
sendOne pid (fileUri,ds) = do
publishDiagnostics maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds)])
hasSeverity :: J.DiagnosticSeverity -> J.Diagnostic -> Bool
hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev
hasSeverity _ _ = False
sendEmpty = publishDiagnostics maxToSend file Nothing (Map.fromList [(Just "bios",SL.toSortedList [])])
sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "bios",SL.toSortedList [])])
maxToSend = maxNumberOfProblems clientConfig
let sendHlint = hlintOn clientConfig
@ -930,7 +941,7 @@ requestDiagnosticsNormal tn file mVer = do
let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl
$ ApplyRefact.lintCmd' file
callbackl (PublishDiagnosticsParams fp (List ds))
= sendOne "hlint" (fp, ds)
= sendOne "hlint" (J.toNormalizedUri fp, ds)
makeRequest reql
-- get GHC diagnostics and loads the typechecked module into the cache

45
stack-8.2.1.yaml
View File

@ -1,45 +0,0 @@
resolver: nightly-2017-11-24 # Last one for GHC 8.2.1
packages:
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
# - brittany-0.11.0.0
- butcher-1.3.1.1
- cabal-plan-0.3.0.0
- constrained-dynamic-0.1.0.0
- czipwith-1.0.1.0
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- haddock-api-2.18.1
- haddock-library-1.4.4
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0@rev:2
- hlint-2.0.11
- hsimport-0.10.0
- lsp-test-0.5.2.3
- monad-dijkstra-0.1.1.2
- mtl-2.2.2
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- sorted-list-0.2.1.0
- syz-0.2.0.0
- yaml-0.8.32
flags:
haskell-ide-engine:
pedantic: true
hie-plugin-api:
pedantic: true
nix:
packages: [ icu libcxx zlib ]
concurrent-tests: false

13
stack-8.2.2.yaml
View File

@ -5,13 +5,12 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
# - brittany-0.11.0.0
- brittany-0.12.0.0
- butcher-1.3.1.1
- cabal-plan-0.3.0.0
- conduit-parse-0.2.1.0
@ -21,19 +20,21 @@ extra-deps:
- ghc-exactprint-0.5.8.2
- haddock-api-2.18.1
- haddock-library-1.4.4
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0@rev:2
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.17 # last hlint supporting GHC 8.2
- hoogle-5.0.17.6
- hoogle-5.0.17.9
- hsimport-0.8.8
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- sorted-list-0.2.1.0
- syz-0.2.0.0
# To make build work in windows 7
- unix-time-0.4.7
flags:
haskell-ide-engine:

17
stack-8.4.2.yaml
View File

@ -5,34 +5,35 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
# - brittany-0.11.0.0
- brittany-0.12.0.0
- base-compat-0.9.3
- cabal-plan-0.3.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0@rev:2
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- 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

16
stack-8.4.3.yaml
View File

@ -5,32 +5,34 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- base-compat-0.9.3
- brittany-0.12.0.0
- cabal-plan-0.3.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0@rev:2
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- pretty-show-1.8.2
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
# To make build work in windows 7
- unix-time-0.4.7
- temporary-1.2.1.1
flags:

17
stack-8.4.4.yaml
View File

@ -5,33 +5,34 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
# - brittany-0.11.0.0
- brittany-0.12.0.0
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.20.0
- haddock-library-1.6.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- optparse-simple-0.1.0
- pretty-show-1.9.5
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
# To make build work in windows 7
- unix-time-0.4.7
- temporary-1.2.1.1
flags:

16
stack-8.6.1.yaml
View File

@ -5,13 +5,13 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./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.0.0
- butcher-1.3.2.1
- cabal-install-2.4.0.0
- cabal-plan-0.4.0.0
@ -19,16 +19,16 @@ extra-deps:
- czipwith-1.0.1.1
- data-tree-print-0.1.0.2
- floskell-0.10.0
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.21.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- monoid-subclasses-0.4.6.1
@ -38,6 +38,8 @@ extra-deps:
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
flags:

16
stack-8.6.2.yaml
View File

@ -5,32 +5,34 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- brittany-0.12.0.0
- butcher-1.3.2.1
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.21.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- multistate-0.8.0.1
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
flags:

16
stack-8.6.3.yaml
View File

@ -6,27 +6,27 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- bytestring-trie-0.2.5.0
- brittany-0.12.0.0
- butcher-1.3.2.1
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.21.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- haskell-src-exts-util-0.2.5
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2
- monad-memo-0.4.1
- multistate-0.8.0.1
@ -34,6 +34,8 @@ extra-deps:
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
flags:

16
stack-8.6.4.yaml
View File

@ -6,31 +6,33 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- brittany-0.12.0.0
- butcher-1.3.2.1
- bytestring-trie-0.2.5.0
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- floskell-0.10.0
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.22.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- hlint-2.1.22
- hoogle-5.0.17.6
- hlint-2.2
- hoogle-5.0.17.9
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2@rev:1
- monad-memo-0.4.1
- multistate-0.8.0.1
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- temporary-1.2.1.1
# To make build work in windows 7
- unix-time-0.4.7
- yaml-0.8.32
# allow-newer: true

19
stack-8.6.5.yaml
View File

@ -1,30 +1,29 @@
resolver: nightly-2019-04-30 # First GHC 8.6.5
resolver: lts-13.27
packages:
- .
- hie-plugin-api
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod
- ./submodules/ghc-mod/core
- ./submodules/ghc-mod/ghc-project-types
- ansi-terminal-0.8.2
- brittany-0.12.0.0
- butcher-1.3.2.1
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- deque-0.2.7
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-0.20190523
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.22.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- hlint-2.1.22
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- haskell-src-exts-1.21.0
- hlint-2.2
- hsimport-0.10.0
- lsp-test-0.5.2.3
- hoogle-5.0.17.9
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2@rev:1
- monad-memo-0.4.1
- multistate-0.8.0.1

22
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: nightly-2019-04-30 # First GHC 8.6.5
resolver: nightly-2019-07-07 # GHC 8.6.5
packages:
- .
- hie-plugin-api
@ -6,29 +6,25 @@ packages:
extra-deps:
- ./submodules/HaRe
- ./submodules/brittany
- ./submodules/cabal-helper
- ./submodules/ghc-mod/ghc-project-types
- ansi-terminal-0.8.2
- butcher-1.3.2.1
- bytestring-trie-0.2.5.0
- ansi-wl-pprint-0.6.8.2
- brittany-0.12.0.0
- cabal-plan-0.4.0.0
- constrained-dynamic-0.1.0.0
- deque-0.2.7
- floskell-0.10.0
- ghc-exactprint-0.5.8.2
- ghc-lib-parser-0.20190523
- floskell-0.10.1
- ghc-lib-parser-8.8.0.20190424
- haddock-api-2.22.0
- haskell-lsp-0.13.0.0
- haskell-lsp-types-0.13.0.0
- hlint-2.1.22
- haskell-lsp-0.15.0.0
- haskell-lsp-types-0.15.0.0
- hlint-2.2
- hsimport-0.10.0
- lsp-test-0.5.2.3
- lsp-test-0.6.0.0
- monad-dijkstra-0.1.1.2@rev:1
- monad-memo-0.4.1
- multistate-0.8.0.1
- rope-utf16-splay-0.3.1.0
- syz-0.2.0.0
- temporary-1.2.1.1
- yaml-0.8.32

1
submodules/brittany

@ -1 +0,0 @@
Subproject commit 6c187da8f8166d595f36d6aaf419370283b3d1e9

2
submodules/ghc-mod

@ -1 +1 @@
Subproject commit 43476965b5d715f7fcdadd9e14d5e0c53cdb9385
Subproject commit 910887b2c33237b703417ec07f35ca8bbf35d729

4
test/dispatcher/Main.hs
View File

@ -174,7 +174,7 @@ funcSpec = describe "functional dispatch" $ do
-- followed by the diagnostics ...
("req2",Right res2) <- atomically $ readTChan logChan
show res2 `shouldBe` "((Map Uri (Set Diagnostic)),[Text])"
show res2 `shouldBe` "(Diagnostics,[Text])"
-- No more pending results
rr3 <- atomically $ tryReadTChan logChan
@ -281,7 +281,7 @@ funcSpec = describe "functional dispatch" $ do
unpackRes hr7 `shouldBe` ("req7", Just ([] :: [Location]))
("req8", Right diags) <- atomically $ readTChan logChan
show diags `shouldBe` "((Map Uri (Set Diagnostic)),[Text])"
show diags `shouldBe` "(Diagnostics,[Text])"
killThread dispatcher

61
test/functional/CompletionSpec.hs
View File

@ -250,6 +250,67 @@ spec = describe "completions" $ do
item ^. insertTextFormat `shouldBe` Just Snippet
item ^. insertText `shouldBe` Just "mapM ${1:a -> m b} ${2:t a}"
it "work for infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- skipManyTill loggingNotification (count 2 noDiagnostics)
let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 5 18)
let item = head $ filter ((== "filter") . (^. label)) compls
liftIO $ do
item ^. label `shouldBe` "filter"
item ^. kind `shouldBe` Just CiFunction
item ^. insertTextFormat `shouldBe` Just Snippet
item ^. insertText `shouldBe` Just "filter`"
it "work for infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- skipManyTill loggingNotification (count 2 noDiagnostics)
let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 5 18)
let item = head $ filter ((== "filter") . (^. label)) compls
liftIO $ do
item ^. label `shouldBe` "filter"
item ^. kind `shouldBe` Just CiFunction
item ^. insertTextFormat `shouldBe` Just Snippet
item ^. insertText `shouldBe` Just "filter"
it "work for qualified infix functions" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- skipManyTill loggingNotification (count 2 noDiagnostics)
let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 5 29)
let item = head $ filter ((== "intersperse") . (^. label)) compls
liftIO $ do
item ^. label `shouldBe` "intersperse"
item ^. kind `shouldBe` Just CiFunction
item ^. insertTextFormat `shouldBe` Just Snippet
item ^. insertText `shouldBe` Just "intersperse`"
it "work for qualified infix functions in backticks" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- skipManyTill loggingNotification (count 2 noDiagnostics)
let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`"
_ <- applyEdit doc te
compls <- getCompletions doc (Position 5 29)
let item = head $ filter ((== "intersperse") . (^. label)) compls
liftIO $ do
item ^. label `shouldBe` "intersperse"
item ^. kind `shouldBe` Just CiFunction
item ^. insertTextFormat `shouldBe` Just Snippet
item ^. insertText `shouldBe` Just "intersperse"
it "respects lsp configuration" $ runSession hieCommand fullCaps "test/testdata/completion" $ do
doc <- openDoc "Completion.hs" "haskell"
_ <- skipManyTill loggingNotification (count 2 noDiagnostics)

155
test/functional/FunctionalCodeActionsSpec.hs
View File

@ -127,7 +127,7 @@ spec = describe "code actions" $ do
liftIO $ x `shouldBe` "foo = putStrLn \"world\""
describe "import suggestions" $ do
hsImportSpec "brittany"
describe "formats with brittany" $ hsImportSpec "brittany"
[ -- Expected output for simple format.
[ "import qualified Data.Maybe"
, "import Control.Monad"
@ -153,8 +153,27 @@ spec = describe "code actions" $ do
, " $ hPutStrLn stdout"
, " $ fromMaybe \"Good night, World!\" (Just \"Hello, World!\")"
]
, -- Complex imports for Constructos and functions
[ "{-# LANGUAGE NoImplicitPrelude #-}"
, "import System.IO ( IO"
, " , hPutStrLn"
, " , stderr"
, " )"
, "import Prelude ( Bool(..) )"
, "import Control.Monad ( when )"
, "import Data.Function ( ($) )"
, "import Data.Maybe ( fromMaybe"
, " , Maybe(Just)"
, " )"
, "-- | Main entry point to the program"
, "main :: IO ()"
, "main ="
, " when True"
, " $ hPutStrLn stderr"
, " $ fromMaybe \"Good night, World!\" (Just \"Hello, World!\")"
]
]
hsImportSpec "floskell"
describe "formats with floskell" $ hsImportSpec "floskell"
[ -- Expected output for simple format.
[ "import qualified Data.Maybe"
, "import Control.Monad"
@ -178,6 +197,20 @@ spec = describe "code actions" $ do
, " $ hPutStrLn stdout"
, " $ fromMaybe \"Good night, World!\" (Just \"Hello, World!\")"
]
, -- Complex imports for Constructos and functions
[ "{-# LANGUAGE NoImplicitPrelude #-}"
, "import System.IO (IO, hPutStrLn, stderr)"
, "import Prelude (Bool(..))"
, "import Control.Monad (when)"
, "import Data.Function (($))"
, "import Data.Maybe (fromMaybe, Maybe(Just))"
, "-- | Main entry point to the program"
, "main :: IO ()"
, "main ="
, " when True"
, " $ hPutStrLn stderr"
, " $ fromMaybe \"Good night, World!\" (Just \"Hello, World!\")"
]
]
describe "add package suggestions" $ do
-- Only execute this test with ghc 8.4.4, below seems to be broken in the package.
@ -235,32 +268,6 @@ spec = describe "code actions" $ do
T.lines contents !! 3 `shouldSatisfy` T.isSuffixOf "zlib"
T.lines contents !! 21 `shouldNotSatisfy` T.isSuffixOf "zlib"
it "adds to hpack package.yaml files if both are present" $
runSession hieCommand fullCaps "test/testdata/addPackageTest/hybrid-exe" $ do
doc <- openDoc "app/Asdf.hs" "haskell"
-- ignore the first empty hlint diagnostic publish
[_,diag:_] <- count 2 waitForDiagnostics
let preds = [ T.isPrefixOf "Could not load module ‘Codec.Compression.GZip’"
, T.isPrefixOf "Could not find module ‘Codec.Compression.GZip’"
]
in liftIO $ diag ^. L.message `shouldSatisfy` \x -> any (\f -> f x) preds
mActions <- getAllCodeActions doc
let allActions = map fromAction mActions
action = head allActions
liftIO $ do
action ^. L.title `shouldBe` "Add zlib as a dependency"
forM_ allActions $ \a -> a ^. L.kind `shouldBe` Just CodeActionQuickFix
forM_ allActions $ \a -> a ^. L.command . _Just . L.command `shouldSatisfy` T.isSuffixOf "package:add"
executeCodeAction action
contents <- getDocumentEdit . TextDocumentIdentifier =<< getDocUri "package.yaml"
liftIO $
T.lines contents !! 21 `shouldSatisfy` T.isSuffixOf "zlib"
-- -----------------------------------
@ -504,7 +511,7 @@ spec = describe "code actions" $ do
-- Parameterized HsImport Spec.
-- ---------------------------------------------------------------------
hsImportSpec :: T.Text -> [[T.Text]]-> Spec
hsImportSpec formatterName [e1, e2, e3] =
hsImportSpec formatterName [e1, e2, e3, e4] =
describe ("Execute HsImport with formatter " <> T.unpack formatterName) $ do
it "works with 3.8 code action kinds" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImport.hs" "haskell"
@ -576,9 +583,8 @@ hsImportSpec formatterName [e1, e2, e3] =
, "Import module Data.Maybe (fromMaybe)"
]
executeAllCodeActions doc wantedCodeActionTitles
contents <- executeAllCodeActions doc wantedCodeActionTitles
contents <- documentContents doc
liftIO $ Set.fromList (T.lines contents) `shouldBe` Set.fromList e3
it "respects format config, multiple import-list" $ runSession hieCommand fullCaps "test/testdata" $ do
@ -593,8 +599,7 @@ hsImportSpec formatterName [e1, e2, e3] =
, "Import module Data.Maybe (fromMaybe)"
]
executeAllCodeActions doc wantedCodeActionTitles
contents <- documentContents doc
contents <- executeAllCodeActions doc wantedCodeActionTitles
liftIO $ Set.fromList (T.lines contents) `shouldBe`
Set.fromList
[ "import System.IO (stdout, hPutStrLn)"
@ -626,7 +631,7 @@ hsImportSpec formatterName [e1, e2, e3] =
l3 `shouldBe` "main :: IO ()"
l4 `shouldBe` "main = when True $ putStrLn \"hello\""
it ("import-list respects format config with " <> T.unpack formatterName) $ runSession hieCommand fullCaps "test/testdata" $ do
it "import-list respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportBrittany.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
@ -644,14 +649,74 @@ hsImportSpec formatterName [e1, e2, e3] =
l2 `shouldBe` "import Control.Monad (when)"
l3 `shouldBe` "main :: IO ()"
l4 `shouldBe` "main = when True $ putStrLn \"hello\""
it "complex import-list" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportListElaborate.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
let config = def { formatOnImportOn = True, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
let wantedCodeActionTitles = [ "Import module System.IO (hPutStrLn)"
, "Import module Control.Monad (when)"
, "Import module Data.Maybe (fromMaybe)"
, "Import module Data.Function (($))"
, "Import module Data.Maybe (Maybe (Just))"
, "Import module Prelude (Bool (..))"
, "Import module System.IO (stderr)"
]
contents <- executeAllCodeActions doc wantedCodeActionTitles
liftIO $
T.lines contents `shouldBe` e4
it "complex import-list respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do
doc <- openDoc "CodeActionImportListElaborate.hs" "haskell"
_ <- waitForDiagnosticsSource "ghcmod"
let config = def { formatOnImportOn = False, formattingProvider = formatterName }
sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))
let wantedCodeActionTitles = [ "Import module System.IO (hPutStrLn)"
, "Import module Control.Monad (when)"
, "Import module Data.Maybe (fromMaybe)"
, "Import module Data.Function (($))"
, "Import module Data.Maybe (Maybe (Just))"
, "Import module Prelude (Bool (..))"
, "Import module System.IO (stderr)"
]
contents <- executeAllCodeActions doc wantedCodeActionTitles
liftIO $
T.lines contents `shouldBe`
[ "{-# LANGUAGE NoImplicitPrelude #-}"
, "import System.IO (IO, hPutStrLn, stderr)"
, "import Prelude (Bool(..))"
, "import Control.Monad (when)"
, "import Data.Function (($))"
, "import Data.Maybe (fromMaybe, Maybe(Just))"
, "-- | Main entry point to the program"
, "main :: IO ()"
, "main ="
, " when True"
, " $ hPutStrLn stderr"
, " $ fromMaybe \"Good night, World!\" (Just \"Hello, World!\")"
]
where
executeAllCodeActions :: TextDocumentIdentifier -> [T.Text] -> Session ()
executeAllCodeActions :: TextDocumentIdentifier -> [T.Text] -> Session T.Text
executeAllCodeActions doc names =
replicateM_ (length names) $ do
_ <- waitForDiagnosticsSource "ghcmod"
executeCodeActionByName doc names
_ <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
waitForDiagnosticsSource "ghcmod"
foldM (\_ _ -> do
_ <- waitForDiagnosticsSource "ghcmod"
executeCodeActionByName doc names
content <- skipManyTill publishDiagnosticsNotification $ getDocumentEdit doc
_ <- waitForDiagnosticsSource "ghcmod"
return content
)
(T.pack "")
[ 1 .. length names ]
executeCodeActionByName :: TextDocumentIdentifier -> [T.Text] -> Session ()
executeCodeActionByName doc names = do
@ -660,17 +725,17 @@ hsImportSpec formatterName [e1, e2, e3] =
let actions = filter (\actn -> actn ^. L.title `elem` names) allActions
case actions of
(action:_) -> executeCodeAction action
xs ->
[] ->
error
$ "Found an unexpected amount of action. Expected 1, but got: "
++ show (length xs)
++ "\n. Titles: " ++ show (map (^. L.title) allActions)
$ "No action found to be executed!"
++ "\n Actual actions titles: " ++ show (map (^. L.title) allActions)
++ "\n Expected actions titles: " ++ show names
-- Silence warnings
hsImportSpec formatter args =
error $ "Not the right amount of arguments for \"hsImportSpec ("
++ T.unpack formatter
++ ")\", expected 3, got "
++ ")\", expected 4, got "
++ show (length args)
-- ---------------------------------------------------------------------

8
test/testdata/CodeActionImportListElaborate.hs vendored Normal file
View File

@ -0,0 +1,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
import System.IO (IO)
-- | Main entry point to the program
main :: IO ()
main =
when True
$ hPutStrLn stderr
$ fromMaybe "Good night, World!" (Just "Hello, World!")

2
test/testdata/addPackageTest/hybrid-exe/AddPackage.hs vendored
View File

@ -1,2 +0,0 @@
import Data.Text
foo = pack "I'm a Text"

5
test/testdata/addPackageTest/hybrid-exe/app/Asdf.hs vendored
View File

@ -1,5 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
import Codec.Compression.GZip
main = return $ compress "hello"

60
test/testdata/addPackageTest/hybrid-exe/asdf.cabal vendored
View File

@ -1,60 +0,0 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: a63a1c272a979a805027c5855cbe062ec4698b6ea6dbe59dd5f7aa34b15656a6
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
library
other-modules:
Paths_asdf
hs-source-dirs:
src
build-depends:
base >=4.7 && <5
default-language: Haskell2010
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:
asdf
, base >=4.7 && <5
default-language: Haskell2010
test-suite asdf-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
Paths_asdf
hs-source-dirs:
test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
asdf
, base >=4.7 && <5
default-language: Haskell2010

34
test/testdata/addPackageTest/hybrid-exe/package.yaml vendored
View File

@ -1,34 +0,0 @@
name: asdf
version: 0.1.0.0
github: "githubuser/asdf"
license: BSD3
author: "Author name here"
maintainer: "example@example.com"
copyright: "2018 Author name here"
extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/asdf#readme>
library:
source-dirs: src
executables:
asdf-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- asdf

5
test/testdata/addPackageTest/hybrid-lib/app/Asdf.hs vendored
View File

@ -1,5 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Asdf where
import Codec.Compression.GZip
main = return $ compress "hello"

36
test/testdata/addPackageTest/hybrid-lib/asdf.cabal vendored
View File

@ -1,36 +0,0 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: 0a09a2280cfeb48f88861d105a48255e71ec34cc865390f1d038119511564661
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
library
exposed-modules:
Asdf
other-modules:
Paths_asdf
hs-source-dirs:
app
build-depends:
base >=4.7 && <5
default-language: Haskell2010

25
test/testdata/addPackageTest/hybrid-lib/package.yaml vendored
View File

@ -1,25 +0,0 @@
name: asdf
version: 0.1.0.0
github: "githubuser/asdf"
license: BSD3
author: "Author name here"
maintainer: "example@example.com"
copyright: "2018 Author name here"
extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/githubuser/asdf#readme>
library:
source-dirs: app
dependencies:
- base >= 4.7 && < 5

3
test/testdata/completion/Completion.hs vendored
View File

@ -4,3 +4,6 @@ import qualified Data.List
main :: IO ()
main = putStrLn "hello"
foo :: Either a b -> Either a b
foo = id

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

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

1
test/testdata/wrapper/8.2.1/cabal.project vendored Normal file
View File

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

25
test/testdata/wrapper/8.2.1/cabal1.cabal vendored Normal file
View File

@ -0,0 +1,25 @@
-- Initial cabal1.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: cabal1
version: 0.1.0.0
-- synopsis:
-- description:
license: PublicDomain
-- license-file: LICENSE
author: Alan Zimmerman
maintainer: alan.zimm@gmail.com
-- copyright:
-- category:
build-type: Simple
-- extra-source-files:
-- cabal-helper for cabal 2.2/GHC 8.4 needs a cabal version >= 2
cabal-version: >=2.0
executable cabal1
main-is: main.hs
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <5
hs-source-dirs: src
default-language: Haskell2010

3
test/testdata/wrapper/8.2.1/src/Foo/Bar.hs vendored Normal file
View File

@ -0,0 +1,3 @@
module Foo.Bar where
baz = 6

7
test/testdata/wrapper/8.2.1/src/main.hs vendored Normal file
View File

@ -0,0 +1,7 @@
-- | Testing that HaRe can find source files from a cabal file
import qualified Foo.Bar as B
main = putStrLn "foo"
baz = 3 + B.baz

2
test/testdata/wrapper/lts-11.14/Setup.hs vendored Normal file
View File

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

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

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

25
test/testdata/wrapper/lts-11.14/cabal1.cabal vendored Normal file
View File

@ -0,0 +1,25 @@
-- Initial cabal1.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: cabal1
version: 0.1.0.0
-- synopsis:
-- description:
license: PublicDomain
-- license-file: LICENSE
author: Alan Zimmerman
maintainer: alan.zimm@gmail.com
-- copyright:
-- category:
build-type: Simple
-- extra-source-files:
-- cabal-helper for cabal 2.2/GHC 8.4 needs a cabal version >= 2
cabal-version: >=2.0
executable cabal1
main-is: main.hs
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <5
hs-source-dirs: src
default-language: Haskell2010

3
test/testdata/wrapper/lts-11.14/src/Foo/Bar.hs vendored Normal file
View File

@ -0,0 +1,3 @@
module Foo.Bar where
baz = 6

7
test/testdata/wrapper/lts-11.14/src/main.hs vendored Normal file
View File

@ -0,0 +1,7 @@
-- | Testing that HaRe can find source files from a cabal file
import qualified Foo.Bar as B
main = putStrLn "foo"
baz = 3 + B.baz

6
test/unit/ApplyRefactPluginSpec.hs
View File

@ -100,12 +100,12 @@ applyRefactSpec = do
{ _uri = filePath
, _diagnostics = List
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))
[Diagnostic {_range = Range { _start = Position {_line = 13, _character = 0}
, _end = Position {_line = 13, _character = 100000}}
[Diagnostic {_range = Range { _start = Position {_line = 12, _character = 23}
, _end = Position {_line = 12, _character = 100000}}
, _severity = Just DsInfo
, _code = Just "parser"
, _source = Just "hlint"
, _message = T.pack filePathNoUri <> ":13:24: error:\n Operator applied to too few arguments: +\n data instance Sing (z :: (a :~: b)) where\n SRefl :: Sing Refl +\n> \n\n"
, _message = T.pack filePathNoUri <> ":13:24: error:\n Operator applied to too few arguments: +\n data instance Sing (z :: (a :~: b)) where\n> SRefl :: Sing Refl +\n\n"
, _relatedInformation = Nothing }]}
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)))
[Diagnostic {_range = Range { _start = Position {_line = 13, _character = 0}

13
test/unit/CodeActionsSpec.hs
View File

@ -15,19 +15,22 @@ spec = do
describe "import code actions" $ do
it "pick up variable not in scope" $
let msg = "Variable not in scope: fromJust :: Maybe Integer -> t"
in extractImportableTerm msg `shouldBe` Just "fromJust :: Maybe Integer -> t"
in extractImportableTerm msg `shouldBe` Just ("fromJust :: Maybe Integer -> t", Import Symbol)
it "pick up variable not in scope with 'perhaps you meant'" $
let msg = "• Variable not in scope: msgs :: T.Text\n• Perhaps you meant ‘msg’ (line 90)"
in extractImportableTerm msg `shouldBe` Just "msgs :: T.Text"
in extractImportableTerm msg `shouldBe` Just ("msgs :: T.Text", Import Symbol)
it "pick up multi-line variable not in scope" $
let msg = "Variable not in scope:\nliftIO\n:: IO [FilePath]\n-> GhcMod.Monad.Newtypes.GmT\n (GhcMod.Monad.Newtypes.GmOutT IdeM) [[t0]]"
in extractImportableTerm msg `shouldBe` Just "liftIO :: IO [FilePath] -> GhcMod.Monad.Newtypes.GmT (GhcMod.Monad.Newtypes.GmOutT IdeM) [[t0]]"
in extractImportableTerm msg `shouldBe` Just ("liftIO :: IO [FilePath] -> GhcMod.Monad.Newtypes.GmT (GhcMod.Monad.Newtypes.GmOutT IdeM) [[t0]]", Import Symbol)
it "pick up when" $
let msg = "Variable not in scope: when :: Bool -> IO () -> t"
in extractImportableTerm msg `shouldBe` Just "when :: Bool -> IO () -> t"
in extractImportableTerm msg `shouldBe` Just ("when :: Bool -> IO () -> t", Import Symbol)
it "pick up data constructors" $
let msg = "Data constructor not in scope: ExitFailure :: Integer -> t"
in extractImportableTerm msg `shouldBe` Just "ExitFailure :: Integer -> t"
in extractImportableTerm msg `shouldBe` Just ("ExitFailure :: Integer -> t", Import Constructor)
it "pick up type" $
let msg = "Not in scope: type constructor or class ‘Text"
in extractImportableTerm msg `shouldBe` Just ("Text", Import Type)
describe "rename code actions" $ do
it "pick up variable not in scope perhaps you meant" $

547
test/unit/GhcModPluginSpec.hs
View File

@ -10,14 +10,559 @@ import Data.Monoid
#endif
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.PluginUtils
import Haskell.Ide.Engine.Support.HieExtras
import Language.Haskell.LSP.Types (TextEdit (..))
import Language.Haskell.LSP.Types (TextEdit (..), toNormalizedUri)
import System.Directory
import TestUtils
import Test.Hspec
-- ---------------------------------------------------------------------
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "ghc-mod plugin" ghcmodSpec
-- ---------------------------------------------------------------------
testPlugins :: IdePlugins
testPlugins = pluginDescToIdePlugins [ghcmodDescriptor "ghcmod"]
-- ---------------------------------------------------------------------
ghcmodSpec :: Spec
ghcmodSpec =
describe "ghc-mod plugin commands(old plugin api)" $ do
it "runs the check command" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "./FileWithWarning.hs"
let act = setTypecheckedModule arg
arg = filePathToUri fp
IdeResultOk (_,env) <- runSingle testPlugins act
case env of
[] -> return ()
[s] -> T.unpack s `shouldStartWith` "Loaded package environment from"
ss -> fail $ "got:" ++ show ss
let
res = IdeResultOk $
(Diagnostics (Map.singleton (toNormalizedUri arg) (S.singleton diag)), env)
diag = Diagnostic (Range (toPos (4,7))
(toPos (4,8)))
(Just DsError)
Nothing
(Just "ghcmod")
"Variable not in scope: x"
Nothing
testCommand testPlugins act "ghcmod" "check" arg res
-- ---------------------------------
it "runs the lint command" $ withCurrentDirectory "./test/testdata" $ do
pendingWith "make sure we test this elsewhere"
-- fp <- makeAbsolute "FileWithWarning.hs"
-- let uri = filePathToUri fp
-- act = lintCmd' uri
-- arg = uri
-- #if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)))
-- res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULPerhaps:\NUL return (3 + x)\n")
-- #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
-- ---------------------------------
-- it "runs the info command" $ withCurrentDirectory "./test/testdata" $ do
-- fp <- makeAbsolute "HaReRename.hs"
-- let uri = filePathToUri fp
-- act = infoCmd' uri "main"
-- 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
-- ----------------------------------------------------------------------------
it "runs the type command, find type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "HaReRename.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (5,9)) uri
arg = TP False uri (toPos (5,9))
res = IdeResultOk
[ (Range (toPos (5,9)) (toPos (5,10)), "Int")
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, find function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "HaReRename.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (2,11)) uri
arg = TP False uri (toPos (2,11))
res = IdeResultOk
[ (Range (toPos (2, 8)) (toPos (2,16)), "String -> IO ()")
, (Range (toPos (2, 1)) (toPos (2,24)), "IO ()")
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, no type at location" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "HaReRename.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (1,1)) uri
arg = TP False uri (toPos (1,1))
res = IdeResultOk []
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, simple" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (6,16)) uri
arg = TP False uri (toPos (6,16))
res = IdeResultOk
[ (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
it "runs the type command, sum type pattern match, just" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (6,6)) uri
arg = TP False uri (toPos (6, 6))
res = IdeResultOk
[ (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int")
, (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
it "runs the type command, sum type pattern match, just value" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (6,11)) uri
arg = TP False uri (toPos (6, 11))
res = IdeResultOk
[ (Range (toPos (6, 11)) (toPos (6, 12)), "Int")
, (Range (toPos (6, 6)) (toPos (6, 12)), "Maybe Int")
, (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
it "runs the type command, sum type pattern match, nothing" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (7,5)) uri
arg = TP False uri (toPos (7,5))
res = IdeResultOk
[ (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
it "runs the type command, sum type pattern match, nothing, literal" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (7,15)) uri
arg = TP False uri (toPos (7,15))
res = IdeResultOk
[ (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
it "runs the type command, variable matching" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (10,5)) uri
arg = TP False uri (toPos (10,5))
res = IdeResultOk
[ (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
it "runs the type command, case expr" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (10,14)) uri
arg = TP False uri (toPos (10,14))
res = IdeResultOk
[ (Range (toPos (10, 14)) (toPos (10, 15)), "Maybe Int")
, (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
it "runs the type command, case expr match, just" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (11,5)) uri
arg = TP False uri (toPos (11,5))
res = IdeResultOk
[ (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")
, (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
it "runs the type command, case expr match, just value" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (11,10)) uri
arg = TP False uri (toPos (11,10))
res = IdeResultOk
[ (Range (toPos (11, 10)) (toPos (11, 11)), "Int")
, (Range (toPos (11, 5)) (toPos (11, 11)), "Maybe Int")
, (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
it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (11,17)) uri
arg = TP False uri (toPos (11,17))
res = IdeResultOk
[ (Range (toPos (11, 17)) (toPos (11, 18)), "Int -> Int -> Int")
, (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
it "runs the type command, case expr match, nothing" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (12,5)) uri
arg = TP False uri (toPos (12,5))
res = IdeResultOk
[ (Range (toPos (12, 5)) (toPos (12, 12)), "Maybe Int")
, (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
it "runs the type command, do bind expr result " $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (16,5)) uri
arg = TP False uri (toPos (16,5))
res = IdeResultOk
[ (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
it "runs the type command, do bind expr" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (16,10)) uri
arg = TP False uri (toPos (16,10))
res = IdeResultOk
[ (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
it "runs the type command, let binding function, return func" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (17,13)) uri
arg = TP False uri (toPos (17,13))
res = IdeResultOk
[ (Range (toPos (17, 13)) (toPos (17, 19)), "Int -> Maybe Int")
, (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
it "runs the type command, let binding function, return param" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (17,21)) uri
arg = TP False uri (toPos (17,21))
res = IdeResultOk
[ (Range (toPos (17, 21)) (toPos (17, 22)), "Int")
, (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
it "runs the type command, let binding function, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (17,9)) uri
arg = TP False uri (toPos (17,9))
res = IdeResultOk
[ (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
it "runs the type command, do expr, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (18,10)) uri
arg = TP False uri (toPos (18,10))
res = IdeResultOk
[ (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
it "runs the type command, let binding function, do expr bind for local func" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (18,5)) uri
arg = TP False uri (toPos (18,5))
res = IdeResultOk
[ (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
it "runs the type command, function type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (15,5)) uri
arg = TP False uri (toPos (15,5))
res = IdeResultOk
[ (Range (toPos (15, 1)) (toPos (19, 19)), "Maybe Int -> Maybe Int")
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, function parameter" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (22,10)) uri
arg = TP False uri (toPos (22,10))
res = IdeResultOk
[ (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
it "runs the type command, function composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (25,26)) uri
arg = TP False uri (toPos (25,26))
res = IdeResultOk
[ (Range (toPos (25, 26)) (toPos (25, 27)), "(b -> c) -> (a -> b) -> a -> c")
, (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
it "runs the type command, let binding, function composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (25,20)) uri
arg = TP False uri (toPos (25,20))
res = IdeResultOk
[ (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
it "runs the type command, let binding, type of function" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (25,33)) uri
arg = TP False uri (toPos (25,33))
res = IdeResultOk
[ (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
it "runs the type command, function type composition" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (25,5)) uri
arg = TP False uri (toPos (25,5))
res = IdeResultOk
[ (Range (toPos (25, 1)) (toPos (25, 34)), "(b -> c) -> (a -> b) -> a -> c")
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, infix operator" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (28,25)) uri
arg = TP False uri (toPos (28,25))
res = IdeResultOk
[ (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
it "runs the type command, constructor" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (31,7)) uri
arg = TP False uri (toPos (31,7))
res = IdeResultOk
[ -- (Range (toPos (31, 7)) (toPos (31, 12)), "Int -> Test")
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, deriving clause Show type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (33,15)) uri
arg = TP False uri (toPos (33,15))
res = IdeResultOk
[ (Range (toPos (33, 15)) (toPos (33, 19)), "(Int -> Test -> ShowS) -> (Test -> String) -> ([Test] -> ShowS) -> Show Test")
, (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS")
, (Range (toPos (33, 15)) (toPos (33, 19)), "Test -> String")
, (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS")
, (Range (toPos (33, 15)) (toPos (33, 19)), "Int -> Test -> ShowS")
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))
#else
, (Range (toPos (33, 15)) (toPos (33, 19)), "[Test] -> ShowS")
#endif
]
testCommand testPlugins act "ghcmod" "type" arg res
it "runs the type command, deriving clause Eq type" $ withCurrentDirectory "./test/testdata" $ do
fp <- makeAbsolute "Types.hs"
let uri = filePathToUri fp
act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (33,21)) uri
arg = TP False uri (toPos (33,21))
res = IdeResultOk
[ (Range (toPos (33, 21)) (toPos (33, 23)), "(Test -> Test -> Bool) -> (Test -> Test -> Bool) -> Eq Test")
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)))
#else
, (Range (toPos (33, 21)) (toPos (33, 23)), "Test -> Test -> Bool")
#endif
]
testCommand testPlugins act "ghcmod" "type" arg res
-- ----------------------------------------------------------------------------
it "runs the type command with an absolute path from another folder, correct params" $ do
fp <- makeAbsolute "./test/testdata/HaReRename.hs"
cd <- getCurrentDirectory
cd2 <- getHomeDirectory
bracket (setCurrentDirectory cd2)
(\_->setCurrentDirectory cd)
$ \_-> do
let uri = filePathToUri fp
let act = do
_ <- setTypecheckedModule uri
liftToGhc $ newTypeCmd (toPos (5,9)) uri
let arg = TP False uri (toPos (5,9))
let res = IdeResultOk
[(Range (toPos (5,9)) (toPos (5,10)), "Int")
, (Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
]
testCommand testPlugins act "ghcmod" "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 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

2
test/unit/HooglePluginSpec.hs
View File

@ -48,7 +48,7 @@ hoogleSpec = do
it "runs the info command" $ do
let req = liftToGhc $ infoCmd' "head"
r <- dispatchRequestP $ initializeHoogleDb >> req
r `shouldBe` Right "head :: [a] -> a\nbase Prelude\nExtract the first element of a list, which must be non-empty.\n\n"
r `shouldBe` Right "```haskell\nhead :: [a] -> a\n```\nExtract the first element of a list, which must be non-empty.\n\n[More info](https://hackage.haskell.org/package/base/docs/Prelude.html#v:head)"
-- ---------------------------------

29
test/unit/LiquidSpec.hs
View File

@ -4,7 +4,6 @@ module LiquidSpec where
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.List
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Monoid ((<>))
@ -12,7 +11,6 @@ import Data.Maybe (isJust)
import Haskell.Ide.Engine.MonadTypes
import Haskell.Ide.Engine.Plugin.Liquid
import System.Directory
import System.Exit
import System.FilePath
import Test.Hspec
@ -25,18 +23,23 @@ spec = do
cwd <- runIO getCurrentDirectory
-- ---------------------------------
it "finds liquid haskell exe in $PATH" $ findExecutable "liquid" >>= (`shouldSatisfy` isJust)
-- ---------------------------------
-- This produces some products in /test/testdata/liquid/.liquid/ that is used in subsequent test
it "runs the liquid haskell exe" $ do
let
fp = cwd </> "test/testdata/liquid/Evens.hs"
-- fp = "/home/alanz/tmp/haskell-proc-play/Evens.hs"
-- uri = filePathToUri fp
Just (ef, (msg:_)) <- runLiquidHaskell fp
msg `shouldSatisfy` isPrefixOf "RESULT\n[{\"start\":{\"line\":9,\"column\":1},\"stop\":{\"line\":9,\"column\":8},\"message\":\"Error: Liquid Type Mismatch\\n Inferred type\\n VV : {v : Int | v == (7 : int)}\\n \\n not a subtype of Required type\\n VV : {VV : Int | VV mod 2 == 0}\\n"
ef `shouldBe` ExitFailure 1
-- AZ: this test has been moved to func-tests, stack > 2.1 sets
-- its own package environment, we can't run it from here.
-- -- This produces some products in /test/testdata/liquid/.liquid/ that is used in subsequent test
-- it "runs the liquid haskell exe" $ do
-- let
-- fp = cwd </> "test/testdata/liquid/Evens.hs"
-- -- fp = "/home/alanz/tmp/haskell-proc-play/Evens.hs"
-- -- uri = filePathToUri fp
-- Just (ef, (msg:_)) <- runLiquidHaskell fp
-- msg `shouldSatisfy` isPrefixOf "RESULT\n[{\"start\":{\"line\":9,\"column\":1},\"stop\":{\"line\":9,\"column\":8},\"message\":\"Error: Liquid Type Mismatch\\n Inferred type\\n VV : {v : Int | v == (7 : int)}\\n \\n not a subtype of Required type\\n VV : {VV : Int | VV mod 2 == 0}\\n"
-- ef `shouldBe` ExitFailure 1
-- ---------------------------------
it "gets annot file paths" $ do
@ -44,8 +47,8 @@ spec = do
uri = filePathToUri $ cwd </> "test/testdata/liquid/Evens.hs"
vimFile = vimAnnotFile uri
jsonFile = jsonAnnotFile uri
vimFile `shouldBe` (cwd </> "test/testdata/liquid/.liquid/Evens.hs.vim.annot")
jsonFile `shouldBe` (cwd </> "test/testdata/liquid/.liquid/Evens.hs.json")
vimFile `shouldBe` normalise (cwd </> "test/testdata/liquid/.liquid/Evens.hs.vim.annot")
jsonFile `shouldBe` normalise (cwd </> "test/testdata/liquid/.liquid/Evens.hs.json")
-- ---------------------------------

76
test/unit/PackagePluginSpec.hs
View File

@ -22,7 +22,7 @@ spec :: Spec
spec = describe "Package plugin" packageSpec
testdata :: FilePath
testdata = "test/testdata/addPackageTest"
testdata = "test" </> "testdata" </> "addPackageTest"
testPlugins :: IdePlugins
testPlugins = pluginDescToIdePlugins [packageDescriptor "package"]
@ -31,7 +31,7 @@ cabalProject :: [FilePath]
cabalProject = ["cabal-lib", "cabal-exe"]
hpackProject :: [FilePath]
hpackProject = ["hpack-lib", "hpack-exe", "hybrid-lib", "hybrid-exe"]
hpackProject = ["hpack-lib", "hpack-exe"]
packageSpec :: Spec
packageSpec = do
@ -239,77 +239,7 @@ packageSpec = do
]
]
testCommand testPlugins act "package" "add" args res
it
"Add package to package.yaml in hpack project with generated cabal to executable component"
$ withCurrentDirectory (testdata </> "hybrid-exe")
$ do
let
fp = cwd </> testdata </> "hybrid-exe"
uri = filePathToUri $ fp </> "package.yaml"
args = AddParams fp (fp </> "app" </> "Asdf.hs") "zlib"
act = addCmd' args
res = IdeResultOk
$ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing
textEdits = List
[ TextEdit (Range (Position 0 0) (Position 34 0)) $ T.concat
[ "library:\n"
, " source-dirs: src\n"
, "copyright: 2018 Author name here\n"
, "maintainer: example@example.com\n"
, "name: asdf\n"
, "version: 0.1.0.0\n"
, "extra-source-files:\n"
, "- README.md\n"
, "- ChangeLog.md\n"
, "author: Author name here\n"
, "github: githubuser/asdf\n"
, "license: BSD3\n"
, "executables:\n"
, " asdf-exe:\n"
, " source-dirs: app\n"
, " main: Main.hs\n"
, " ghc-options:\n"
, " - -threaded\n"
, " - -rtsopts\n"
, " - -with-rtsopts=-N\n"
, " dependencies:\n"
, " - zlib\n"
, " - asdf\n"
, "description: Please see the README on GitHub at <https://github.com/githubuser/asdf#readme>\n"
]
]
testCommand testPlugins act "package" "add" args res
it "Add package to package.yaml in hpack project with generated cabal to library component"
$ withCurrentDirectory (testdata </> "hybrid-lib")
$ do
let
fp = cwd </> testdata </> "hybrid-lib"
uri = filePathToUri $ fp </> "package.yaml"
args = AddParams fp (fp </> "app" </> "Asdf.hs") "zlib"
act = addCmd' args
res = IdeResultOk
$ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing
textEdits = List
[ TextEdit (Range (Position 0 0) (Position 25 0)) $ T.concat
[ "library:\n"
, " source-dirs: app\n"
, " dependencies:\n"
, " - zlib\n"
, " - base >= 4.7 && < 5\n"
, "copyright: 2018 Author name here\n"
, "maintainer: example@example.com\n"
, "name: asdf\n"
, "version: 0.1.0.0\n"
, "extra-source-files:\n"
, "- README.md\n"
, "- ChangeLog.md\n"
, "author: Author name here\n"
, "github: githubuser/asdf\n"
, "license: BSD3\n"
, "description: Please see the README on GitHub at <https://github.com/githubuser/asdf#readme>\n"
]
]
testCommand testPlugins act "package" "add" args res
it "Do nothing on NoPackage"
$ withCurrentDirectory (testdata </> "invalid")
$ do

6
test/utils/TestUtils.hs
View File

@ -4,6 +4,7 @@ module TestUtils
withFileLogging
, setupStackFiles
, testCommand
, runSingle
, runSingleReq
, makeRequest
, runIGM
@ -51,6 +52,9 @@ testCommand testPlugins act plugin cmd arg res = do
newApiRes `shouldBe` res
fmap fromDynJSON oldApiRes `shouldBe` fmap Just res
runSingle :: IdePlugins -> IdeGhcM (IdeResult b) -> IO (IdeResult b)
runSingle testPlugins act = runIGM testPlugins act
runSingleReq :: ToJSON a
=> IdePlugins -> PluginId -> CommandName -> a -> IO (IdeResult DynamicJSON)
runSingleReq testPlugins plugin com arg = runIGM testPlugins (makeRequest plugin com arg)
@ -94,10 +98,8 @@ files =
[ "./test/testdata/"
, "./test/testdata/addPackageTest/cabal-exe/"
, "./test/testdata/addPackageTest/hpack-exe/"
, "./test/testdata/addPackageTest/hybrid-exe/"
, "./test/testdata/addPackageTest/cabal-lib/"
, "./test/testdata/addPackageTest/hpack-lib/"
, "./test/testdata/addPackageTest/hybrid-lib/"
, "./test/testdata/addPragmas/"
, "./test/testdata/badProjects/cabal/"
, "./test/testdata/completion/"

2
test/wrapper/HieWrapper.hs
View File

@ -18,4 +18,4 @@ main = hspec $
withCurrentDirectory "test/testdata/wrapper/ghc" $ do
ghcDisplayVer <- readCreateProcess (shell "ghc --version") ""
ghcVer <- getProjectGhcVersion
init ghcDisplayVer `shouldEndWith` ghcVer
init ghcDisplayVer `shouldEndWith` ghcVer