haskell-language-server 0.8.0.0 → 0.9.0.0
raw patch · 34 files changed
+865/−329 lines, 34 filesdep +fuzzydep +hls-haddock-comments-plugindep +hls-splice-plugindep ~ghcidedep ~haskell-lspdep ~hls-class-pluginPVP ok
version bump matches the API change (PVP)
Dependencies added: fuzzy, hls-haddock-comments-plugin, hls-splice-plugin
Dependency ranges changed: ghcide, haskell-lsp, hls-class-plugin, hls-eval-plugin, hls-explicit-imports-plugin, hls-hlint-plugin, hls-plugin-api, hls-retrie-plugin, hls-tactics-plugin
API changes (from Hackage documentation)
Files
- ChangeLog.md +172/−0
- README.md +16/−3
- exe/Main.hs +2/−2
- exe/Plugins.hs +31/−17
- exe/Wrapper.hs +2/−3
- haskell-language-server.cabal +34/−8
- plugins/default/src/Ide/Plugin/Brittany.hs +11/−6
- plugins/default/src/Ide/Plugin/Example.hs +2/−2
- plugins/default/src/Ide/Plugin/Example2.hs +1/−1
- plugins/default/src/Ide/Plugin/Floskell.hs +0/−3
- plugins/default/src/Ide/Plugin/Fourmolu.hs +1/−1
- plugins/default/src/Ide/Plugin/Ormolu.hs +0/−1
- plugins/default/src/Ide/Plugin/Pragmas.hs +53/−23
- plugins/hls-eval-plugin/test/Eval.hs +11/−5
- plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +54/−0
- plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs +27/−0
- plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs +0/−27
- src/Ide/Main.hs +4/−9
- src/Ide/Version.hs +2/−2
- test/functional/Class.hs +9/−1
- test/functional/Command.hs +5/−8
- test/functional/Completion.hs +50/−16
- test/functional/Diagnostic.hs +24/−45
- test/functional/FunctionalBadProject.hs +0/−1
- test/functional/FunctionalCodeAction.hs +96/−12
- test/functional/FunctionalLiquid.hs +5/−70
- test/functional/HaddockComments.hs +76/−0
- test/functional/HieBios.hs +13/−14
- test/functional/Main.hs +4/−0
- test/functional/ModuleName.hs +0/−1
- test/functional/Rename.hs +19/−18
- test/functional/Splice.hs +139/−0
- test/functional/Tactic.hs +2/−4
- test/utils/Test/Hls/Util.hs +0/−26
ChangeLog.md view
@@ -1,5 +1,177 @@ # Changelog for haskell-language-server +## 0.9.0++This release includes lot of refactorings and bug fixes over existing features, hlint and eval plugins among others.+It contains a fix for a bug in ghcide involving stale diagnostics (#1204).++The list of contributors continues to show healthy growth, many thanks to you all!++And remember, we have a new brand logo, courtesy of @Ailrun :slightly_smiling_face:++++### Pull requests merged for 0.9.0++- Do not error out on failed rewrite+([#1269)](https://github.com/haskell/haskell-language-server/pull/1269) by @pepeiborra+- Tighten dependency on apply-refact+([#1268)](https://github.com/haskell/haskell-language-server/pull/1268) by @hololeap+- Add the new logos+([#1267)](https://github.com/haskell/haskell-language-server/pull/1267) by @Ailrun+- Fix a bug in completions+([#1265)](https://github.com/haskell/haskell-language-server/pull/1265) by @pepeiborra+- Produce heap profiles the old fashioned way, from .hp files+([#1261)](https://github.com/haskell/haskell-language-server/pull/1261) by @pepeiborra+- Break down ghcide functionality in HLS plugins+([#1257)](https://github.com/haskell/haskell-language-server/pull/1257) by @pepeiborra+- Enforce max completions over all plugins+([#1256)](https://github.com/haskell/haskell-language-server/pull/1256) by @pepeiborra+- Reorder code actions to put remove redundant imports first+([#1255)](https://github.com/haskell/haskell-language-server/pull/1255) by @pepeiborra+- Update bench.yml to include all the relevant artifacts+([#1254)](https://github.com/haskell/haskell-language-server/pull/1254) by @pepeiborra+- Benchmarks: generate heap profiles+([#1253)](https://github.com/haskell/haskell-language-server/pull/1253) by @pepeiborra+- Add gh workflows badges+([#1251)](https://github.com/haskell/haskell-language-server/pull/1251) by @jneira+- Add dynamic linking common issue+([#1249)](https://github.com/haskell/haskell-language-server/pull/1249) by @jneira+- Add license for hls-tactics-plugin+([#1248)](https://github.com/haskell/haskell-language-server/pull/1248) by @isovector+- Use exact print to extend import lists+([#1246)](https://github.com/haskell/haskell-language-server/pull/1246) by @berberman+- Test apply-refact with TypeApplications+([#1244)](https://github.com/haskell/haskell-language-server/pull/1244) by @jneira+- Add non reversable pragma completion+([#1243)](https://github.com/haskell/haskell-language-server/pull/1243) by @Ailrun+- Delete redundant "category: Development".+([#1241)](https://github.com/haskell/haskell-language-server/pull/1241) by @peterwicksstringfield+- Complete the No- variants of language extensions and Strict extension+([#1238)](https://github.com/haskell/haskell-language-server/pull/1238) by @mrBliss+- Add code actions for disabling a warning in the current file+([#1235)](https://github.com/haskell/haskell-language-server/pull/1235) by @georgefst+- Change packages metadata and rename tactics subfolder+([#1234)](https://github.com/haskell/haskell-language-server/pull/1234) by @jneira+- Fix the bug that generating comments would duplicate existing comments+([#1233)](https://github.com/haskell/haskell-language-server/pull/1233) by @berberman+- Delete global hie.yaml config+([#1230)](https://github.com/haskell/haskell-language-server/pull/1230) by @jneira+- Easy hlint fixes+([#1226)](https://github.com/haskell/haskell-language-server/pull/1226) by @peterwicksstringfield+- Use the runtime ghc libdir for ghc-exactprint+([#1225)](https://github.com/haskell/haskell-language-server/pull/1225) by @jneira+- Add note in README/Tutorial regarding CPP support+([#1224)](https://github.com/haskell/haskell-language-server/pull/1224) by @tittoassini+- Test and fix for issue 1213+([#1223)](https://github.com/haskell/haskell-language-server/pull/1223) by @tittoassini+- Add traces for HLS providers+([#1222)](https://github.com/haskell/haskell-language-server/pull/1222) by @pepeiborra+- Use exact print for suggest missing constraint code actions+([#1221)](https://github.com/haskell/haskell-language-server/pull/1221) by @pepeiborra+- Fix changelog dates+([#1220)](https://github.com/haskell/haskell-language-server/pull/1220) by @pepeiborra+- Ignore .shake folder+([#1219)](https://github.com/haskell/haskell-language-server/pull/1219) by @pepeiborra+- Limit completions to top 40+([#1218)](https://github.com/haskell/haskell-language-server/pull/1218) by @pepeiborra+- Parenthesise type operators when extending import lists+([#1212)](https://github.com/haskell/haskell-language-server/pull/1212) by @mrBliss+- Expose shake options used+([#1209)](https://github.com/haskell/haskell-language-server/pull/1209) by @pepeiborra+- Prepare ghcide release v0.7.1+([#1207)](https://github.com/haskell/haskell-language-server/pull/1207) by @pepeiborra+- Documentation for the Eval Plugin+([#1206)](https://github.com/haskell/haskell-language-server/pull/1206) by @tittoassini+- Stale diagnostics fix+([#1204)](https://github.com/haskell/haskell-language-server/pull/1204) by @pepeiborra+- Extract Development.IDE.GHC.ExactPrint+([#1203)](https://github.com/haskell/haskell-language-server/pull/1203) by @pepeiborra+- Fix bug in Retrie "fold/unfold in local file" commands+([#1202)](https://github.com/haskell/haskell-language-server/pull/1202) by @pepeiborra+- Minor eval plugin fixes+([#1199)](https://github.com/haskell/haskell-language-server/pull/1199) by @tittoassini+- Disable win 8.6.4 job+([#1198)](https://github.com/haskell/haskell-language-server/pull/1198) by @jneira+- Add custom cache layer for session loading+([#1197)](https://github.com/haskell/haskell-language-server/pull/1197) by @fendor+- Use completionSnippetsOn flag+([#1195)](https://github.com/haskell/haskell-language-server/pull/1195) by @takoeight0821+- Remove runs dropped by #1173+([#1194)](https://github.com/haskell/haskell-language-server/pull/1194) by @jneira+- Remove undefined exports suggestions+([#1193)](https://github.com/haskell/haskell-language-server/pull/1193) by @kderme+- Update nixpkgs to ghc 8.10.3+([#1191)](https://github.com/haskell/haskell-language-server/pull/1191) by @pepeiborra+- Do not disable parallel GC+([#1190)](https://github.com/haskell/haskell-language-server/pull/1190) by @pepeiborra+- Switch module outline to useWtihStale+([#1189)](https://github.com/haskell/haskell-language-server/pull/1189) by @pepeiborra+- Fix sticky diagnostics+([#1188)](https://github.com/haskell/haskell-language-server/pull/1188) by @pepeiborra+- Fix class plugin cabal+([#1186)](https://github.com/haskell/haskell-language-server/pull/1186) by @Ailrun+- Update package description of haddock comments plugin+([#1185)](https://github.com/haskell/haskell-language-server/pull/1185) by @berberman+- Installation from Hackage - add README section+([#1183)](https://github.com/haskell/haskell-language-server/pull/1183) by @pepeiborra+- Preparation for Uploading Splice Plugin to Hackage+([#1182)](https://github.com/haskell/haskell-language-server/pull/1182) by @konn+- Preparation for uploading `hls-exactprint-utils`+([#1181)](https://github.com/haskell/haskell-language-server/pull/1181) by @konn+- Complete hls-hlint-plugin package metadata+([#1180)](https://github.com/haskell/haskell-language-server/pull/1180) by @jneira+- Benchmark improvements+([#1178)](https://github.com/haskell/haskell-language-server/pull/1178) by @pepeiborra+- Make adding missing constraint work in presence of 'forall' (fixes #1164)+([#1177)](https://github.com/haskell/haskell-language-server/pull/1177) by @jhrcek+- Prepare for Hackage+([#1176)](https://github.com/haskell/haskell-language-server/pull/1176) by @pepeiborra+- Test only last ghc minor version and fix windows cache+([#1173)](https://github.com/haskell/haskell-language-server/pull/1173) by @jneira+- Fix toMethodName bug of the Class plugin+([#1170)](https://github.com/haskell/haskell-language-server/pull/1170) by @Ailrun+- Quick fix for #1158+([#1166)](https://github.com/haskell/haskell-language-server/pull/1166) by @Ailrun+- Suggest adding pragmas for parse errors too+([#1165)](https://github.com/haskell/haskell-language-server/pull/1165) by @mrBliss+- Fix wrong component name of splice plugin in hie.yaml+([#1162)](https://github.com/haskell/haskell-language-server/pull/1162) by @berberman+- Revert "Auto cancel redundant workflows (attempt #2)"+([#1156)](https://github.com/haskell/haskell-language-server/pull/1156) by @pepeiborra+- Auto cancel redundant workflows (attempt #2)+([#1154)](https://github.com/haskell/haskell-language-server/pull/1154) by @pepeiborra+- Prepare 0.8.0 (versions)+([#1153)](https://github.com/haskell/haskell-language-server/pull/1153) by @jneira+- Streamline CircleCI jobs+([#1152)](https://github.com/haskell/haskell-language-server/pull/1152) by @pepeiborra+- Mergify: create configuration+([#1151)](https://github.com/haskell/haskell-language-server/pull/1151) by @jneira+- Bump haskell-lsp to 0.23+([#1146)](https://github.com/haskell/haskell-language-server/pull/1146) by @berberman+- Remove no longer needed git submodule update+([#1145)](https://github.com/haskell/haskell-language-server/pull/1145) by @jhrcek+- Enable more tests+([#1143)](https://github.com/haskell/haskell-language-server/pull/1143) by @peterwicksstringfield+- Update links to issues/PRs in ghcide tests.+([#1142)](https://github.com/haskell/haskell-language-server/pull/1142) by @peterwicksstringfield+- Fix #723 (Instance declarations in hs-boot files result in GHC errors)+([#781)](https://github.com/haskell/haskell-language-server/pull/781) by @nitros12+- Also suggest importing methods without parent class+([#766)](https://github.com/haskell/haskell-language-server/pull/766) by @mrBliss+- Delete unused utilities for controlling logging.+([#764)](https://github.com/haskell/haskell-language-server/pull/764) by @peterwicksstringfield+- Delete unused testdata+([#763)](https://github.com/haskell/haskell-language-server/pull/763) by @peterwicksstringfield+- Fix suggestAddTypeAnnotation regex+([#760)](https://github.com/haskell/haskell-language-server/pull/760) by @kderme+- Splice Plugin: expands TH splices and QuasiQuotes+([#759)](https://github.com/haskell/haskell-language-server/pull/759) by @konn+- Haddock comments plugin+([#673)](https://github.com/haskell/haskell-language-server/pull/673) by @berberman+- Leverage last apply-refact improvements in hlint plugin (include getParsedModuleWithComments in ghcide)+([#635)](https://github.com/haskell/haskell-language-server/pull/635) by @jneira+ ## 0.8.0 - This version adds support for ghc-8.10.3
README.md view
@@ -1,8 +1,13 @@ # haskell-language-server +![haskell-language-server][logo]+ [![License Apache 2.0][badge-license]][license] [![CircleCI][badge-circleci]][circleci]++ +[logo]: ./docs/logos/logo-256.png [badge-license]: https://img.shields.io/badge/license-Apache2-green.svg?dummy [license]: https://github.com/haskell/haskell-language-server/blob/master/LICENSE [badge-circleci]: https://img.shields.io/circleci/project/github/haskell/haskell-language-server/master.svg@@ -49,9 +54,9 @@ ## Features - - Code evaluation codelens (inspired by [Dante](https://github.com/jyp/dante#-reploid)). You can evaluate code by writing it in a comment of the form -- >>>+- Code evaluation codelens ([Tutorial](plugins/hls-eval-plugin/README.md)): - +  - Type information and documentation on hover. Note that currently, in order for docs to be displayed for dependencies, they must have been built with GHC's `-haddock` flag: @@ -295,9 +300,10 @@ - Format on imports (`haskell.formatOnImportOn`, default true): whether to format after adding an import - Maximum number of problems to report (`haskell.maxNumberOfProblems`, default 100): the maximum number of problems the server will send to the client - Diagnostics on change (`haskell.diagnosticsOnChange`, default true): (currently unused)-- Completion snippets (`haskell.completionSnippetsOn`, default true): whether to support completion snippets (currently unused until we have snippets to provide)+- Completion snippets (`haskell.completionSnippetsOn`, default true): whether to support completion snippets - Liquid Haskell (`haskell.liquidOn`, default false): whether to enable Liquid Haskell support (currently unused until the Liquid Haskell support is functional again) - Hlint (`haskell.hlintOn`, default true): whether to enable Hlint support+- Max completions (`haskell.maxCompletions`, default 40): maximum number of completions sent to the LSP client. Settings like this are typically provided by the language-specific LSP client support for your editor, for example in Emacs by `lsp-haskell`. @@ -633,6 +639,13 @@ These are known to be somewhat buggy at the moment: https://github.com/haskell/haskell-language-server/issues/478. This issue should be fixed in Stack versions >= 2.5.++#### Problems with dynamic linking++As haskell-language-server prebuilt binaries are statically linked, they don't play well with projects using dynamic linking.+An usual symptom is the presence of errors containing `unknown symbol` and it is typical in arch linux, where a dynamically linked version of ghc is used. ++The workaround is to use a version of haskell-language-server compiled from source with `-dynamic` enabled`. See more details [here](https://github.com/haskell/haskell-language-server/issues/1160#issuecomment-756566273). ### Troubleshooting the server
exe/Main.hs view
@@ -16,7 +16,7 @@ let withExamples = case args of- LspMode (LspArguments{..}) -> argsExamplePlugin- _ -> False+ LspMode LspArguments{..} -> argsExamplePlugin+ _ -> False defaultMain args (idePlugins withExamples)
exe/Plugins.hs view
@@ -2,14 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} module Plugins where -import Ide.Types (IdePlugins)+import Ide.Types (IdePlugins) import Ide.PluginUtils (pluginDescToIdePlugins) -- fixed plugins import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Development.IDE (IdeState)-import Development.IDE.Plugin.HLS.GhcIde as GhcIde+import Development.IDE.Plugin.HLS.GhcIde as GhcIde -- haskell-language-server optional plugins @@ -17,6 +17,10 @@ import Ide.Plugin.Class as Class #endif +#if haddockComments+import Ide.Plugin.HaddockComments as HaddockComments+#endif+ #if eval import Ide.Plugin.Eval as Eval #endif@@ -45,6 +49,10 @@ import Ide.Plugin.Pragmas as Pragmas #endif +#if splice+import Ide.Plugin.Splice as Splice+#endif+ -- formatters #if floskell@@ -81,47 +89,53 @@ then basePlugins ++ examplePlugins else basePlugins basePlugins =- [ GhcIde.descriptor "ghcide"+ GhcIde.descriptors ++ #if pragmas- , Pragmas.descriptor "pragmas"+ Pragmas.descriptor "pragmas" : #endif #if floskell- , Floskell.descriptor "floskell"+ Floskell.descriptor "floskell" : #endif #if fourmolu- , Fourmolu.descriptor "fourmolu"+ Fourmolu.descriptor "fourmolu" : #endif #if tactic- , Tactic.descriptor "tactic"+ Tactic.descriptor "tactic" : #endif #if ormolu- , Ormolu.descriptor "ormolu"+ Ormolu.descriptor "ormolu" : #endif #if stylishHaskell- , StylishHaskell.descriptor "stylish-haskell"+ StylishHaskell.descriptor "stylish-haskell" : #endif #if retrie- , Retrie.descriptor "retrie"+ Retrie.descriptor "retrie" : #endif #if AGPL && brittany- , Brittany.descriptor "brittany"+ Brittany.descriptor "brittany" : #endif #if class- , Class.descriptor "class"+ Class.descriptor "class" : #endif+#if haddockComments+ HaddockComments.descriptor "haddockComments" :+#endif #if eval- , Eval.descriptor "eval"+ Eval.descriptor "eval" : #endif #if importLens- , ExplicitImports.descriptor "importLens"+ ExplicitImports.descriptor "importLens" : #endif #if moduleName- , ModuleName.descriptor "moduleName"+ ModuleName.descriptor "moduleName" : #endif #if hlint- , Hlint.descriptor "hlint"+ Hlint.descriptor "hlint" : #endif- ]+#if splice+ Splice.descriptor "splice" :+#endif+ [] examplePlugins = [Example.descriptor "eg" ,Example2.descriptor "eg2"
exe/Wrapper.hs view
@@ -73,7 +73,7 @@ hPutStrLn stderr $ showProgramVersionOfInterest programsOfInterest hPutStrLn stderr "" -- Get the ghc version -- this might fail!- hPutStrLn stderr $ "Consulting the cradle to get project GHC version..."+ hPutStrLn stderr "Consulting the cradle to get project GHC version..." ghcVersion <- getRuntimeGhcVersion' cradle hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion @@ -136,7 +136,7 @@ -- of the project that may or may not be accurate. findLocalCradle :: FilePath -> IO (Cradle Void) findLocalCradle fp = do- cradleConf <- (findCradle defaultLoadingOptions) fp+ cradleConf <- findCradle defaultLoadingOptions fp crdl <- case cradleConf of Just yaml -> do hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\""@@ -144,4 +144,3 @@ Nothing -> loadImplicitCradle fp hPutStrLn stderr $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl return crdl-
haskell-language-server.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 category: Development name: haskell-language-server-version: 0.8.0.0+version: 0.9.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -14,6 +14,7 @@ license: Apache-2.0 license-file: LICENSE build-type: Simple+tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.1 || == 8.10.2 || == 8.10.3 extra-source-files: README.md ChangeLog.md@@ -61,7 +62,7 @@ , ghc , ghcide >=0.7 , gitrev- , haskell-lsp ^>=0.22+ , haskell-lsp ^>=0.23 , hls-plugin-api >=0.6 , hslogger , optparse-applicative@@ -98,6 +99,11 @@ default: True manual: False +flag haddockComments+ description: Enable haddockComments plugin+ default: True+ manual: False+ flag eval description: Enable eval plugin default: True@@ -133,6 +139,11 @@ default: True manual: True +flag splice+ description: Enable splice plugin+ default: True+ manual: False+ -- formatters flag floskell@@ -170,6 +181,11 @@ build-depends: hls-class-plugin cpp-options: -Dclass +common haddockComments+ if flag(haddockComments) || flag(all-plugins)+ build-depends: hls-haddock-comments-plugin+ cpp-options: -DhaddockComments+ common eval if flag(eval) || flag(all-plugins) build-depends: hls-eval-plugin@@ -204,9 +220,15 @@ common pragmas if flag(pragmas) || flag(all-plugins) hs-source-dirs: plugins/default/src+ build-depends: fuzzy other-modules: Ide.Plugin.Pragmas cpp-options: -Dpragmas +common splice+ if flag(splice) || flag(all-plugins)+ build-depends: hls-splice-plugin+ cpp-options: -Dsplice+ -- formatters common floskell@@ -250,6 +272,7 @@ -- plugins , example-plugins , class+ , haddockComments , eval , importLens , retrie@@ -257,6 +280,7 @@ , hlint , moduleName , pragmas+ , splice , floskell , fourmolu , ormolu@@ -272,9 +296,8 @@ -- allow user RTS overrides -rtsopts -- disable idle GC- -- disable parallel GC -- increase nursery size- "-with-rtsopts=-I0 -qg -A128M"+ "-with-rtsopts=-I0 -A128M" if flag(pedantic) ghc-options: -Werror @@ -289,7 +312,7 @@ , ghcide , hashable , haskell-language-server- , haskell-lsp ^>=0.22+ , haskell-lsp ^>=0.23 , lens , regex-tdfa , hslogger@@ -319,9 +342,8 @@ -- allow user RTS overrides -rtsopts -- disable idle GC- -- disable parallel GC -- increase nursery size- "-with-rtsopts=-I0 -qg -A128M"+ "-with-rtsopts=-I0 -A128M" if flag(pedantic) ghc-options: -Werror @@ -390,8 +412,9 @@ , tasty-ant-xml >=1.1.6 , tasty-golden , tasty-rerun+ , ghcide - hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test+ hs-source-dirs: test/functional plugins/hls-tactics-plugin/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src main-is: Main.hs other-modules:@@ -416,6 +439,9 @@ Symbol TypeDefinition Tactic+ Splice+ HaddockComments+ Ide.Plugin.Splice.Types Ide.Plugin.Tactic.TestTypes ghc-options:
plugins/default/src/Ide/Plugin/Brittany.hs view
@@ -1,14 +1,16 @@ module Ide.Plugin.Brittany where +import Control.Exception (bracket_) import Control.Lens import Control.Monad.IO.Class import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) import Data.Coerce+import Data.Maybe (maybeToList) import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T import Development.IDE--- import Development.IDE.Plugin.Formatter+import Development.IDE.GHC.Compat (topDir, ModSummary(ms_hspp_opts)) import Language.Haskell.Brittany import Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J@@ -16,7 +18,7 @@ import Ide.Types import System.FilePath-import Data.Maybe (maybeToList)+import System.Environment (setEnv, unsetEnv) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)@@ -28,14 +30,17 @@ -- If the provider fails an error is returned that can be displayed to the user. provider :: FormattingProvider IdeState IO-provider _lf _ideState typ contents fp opts = do+provider _lf ide typ contents nfp opts = do -- text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do- confFile <- liftIO $ getConfFile fp+ confFile <- liftIO $ getConfFile nfp let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractRange r contents)-- res <- formatText confFile opts selectedContents+ (modsum, _) <- runAction "brittany" ide $ use_ GetModSummary nfp+ let dflags = ms_hspp_opts modsum+ let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key)+ where key = "GHC_EXACTPRINT_GHC_LIBDIR"+ res <- withRuntimeLibdir $ formatText confFile opts selectedContents case res of Left err -> return $ Left $ responseError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Right newText -> return $ Right $ J.List [TextEdit range newText]
plugins/default/src/Ide/Plugin/Example.hs view
@@ -128,7 +128,7 @@ -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing range = Range (Position 3 0) (Position 4 0) let cmdParams = AddTodoParams uri "do abc"- cmd <- mkLspCommand plId "codelens.todo" title (Just [(toJSON cmdParams)])+ cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] @@ -212,7 +212,7 @@ command xd label = "Example completion" kind = Nothing- tags = List []+ tags = Nothing detail = Nothing documentation = Nothing deprecated = Nothing
plugins/default/src/Ide/Plugin/Example2.hs view
@@ -206,7 +206,7 @@ command xd label = "Example2 completion" kind = Nothing- tags = List []+ tags = Nothing detail = Nothing documentation = Nothing deprecated = Nothing
plugins/default/src/Ide/Plugin/Floskell.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Floskell (
plugins/default/src/Ide/Plugin/Fourmolu.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Ide.Plugin.Fourmolu (
plugins/default/src/Ide/Plugin/Ormolu.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}
plugins/default/src/Ide/Plugin/Pragmas.hs view
@@ -1,14 +1,13 @@-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas ( descriptor- -- , commands -- TODO: get rid of this ) where import Control.Lens hiding (List)@@ -25,7 +24,8 @@ import Control.Monad (join) import Development.IDE.GHC.Compat import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.VFS as VFS+import qualified Language.Haskell.LSP.VFS as VFS+import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- @@ -67,10 +67,8 @@ let mFile = docId ^. J.uri & uriToFilePath <&> toNormalizedFilePath' pm <- fmap join $ runAction "addPragma" state $ getParsedModule `traverse` mFile let dflags = ms_hspp_opts . pm_mod_summary <$> pm- -- Filter diagnostics that are from ghcmod- ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags- -- Get all potential Pragmas for all diagnostics.- pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) ghcDiags+ -- Get all potential Pragmas for all diagnostics.+ pragmas = concatMap (\d -> genPragma dflags (d ^. J.message)) diags cmds <- mapM mkCodeAction pragmas return $ Right $ List cmds where@@ -81,13 +79,17 @@ edit = mkPragmaEdit (docId ^. J.uri) pragmaName return codeAction - genPragma mDynflags target- | Just dynFlags <- mDynflags,- -- GHC does not export 'OnOff', so we have to view it as string- disabled <- [ e | Just e <- T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags]- = [ r | r <- findPragma target, r `notElem` disabled]- | otherwise = []-+ genPragma mDynflags target =+ [ r | r <- findPragma target, r `notElem` disabled]+ where+ disabled+ | Just dynFlags <- mDynflags+ -- GHC does not export 'OnOff', so we have to view it as string+ = [ e | Just e <- T.stripPrefix "Off " . T.pack . prettyPrint <$> extensions dynFlags]+ | otherwise+ -- When the module failed to parse, we don't have access to its+ -- dynFlags. In that case, simply don't disable any pragmas.+ = [] -- --------------------------------------------------------------------- @@ -97,13 +99,41 @@ where check p = [p | T.isInfixOf p str] + -- We exclude the Strict extension as it causes many false positives, see+ -- the discussion at https://github.com/haskell/ghcide/pull/638+ --+ -- We don't include the No- variants, as GHC never suggests disabling an+ -- extension in an error message.+ possiblePragmas :: [T.Text]+ possiblePragmas =+ [ name+ | FlagSpec{flagSpecName = T.pack -> name} <- xFlags+ , "Strict" /= name+ ]+ -- --------------------------------------------------------------------- --- | Possible Pragma names.--- See discussion at https://github.com/haskell/ghcide/pull/638-possiblePragmas :: [T.Text]-possiblePragmas = [name | FlagSpec{flagSpecName = T.pack -> name} <- xFlags, "Strict" /= name]+-- | All language pragmas, including the No- variants+allPragmas :: [T.Text]+allPragmas =+ concat+ [ [name, "No" <> name]+ | FlagSpec{flagSpecName = T.pack -> name} <- xFlags+ ]+ <>+ -- These pragmas are not part of xFlags as they are not reversable+ -- by prepending "No".+ [ -- Safe Haskell+ "Unsafe"+ , "Trustworthy"+ , "Safe" + -- Language Version Extensions+ , "Haskell98"+ , "Haskell2010"+ -- Maybe, GHC 2021 after its release?+ ]+ -- --------------------------------------------------------------------- completion :: CompletionProvider IdeState@@ -112,13 +142,13 @@ position = complParams ^. J.position contents <- LSP.getVirtualFileFunc lspFuncs $ toNormalizedUri uri fmap Right $ case (contents, uriToFilePath' uri) of- (Just cnts, Just _path) -> do- pfix <- VFS.getCompletionPrefix position cnts- return $ result pfix+ (Just cnts, Just _path) ->+ result <$> VFS.getCompletionPrefix position cnts where result (Just pfix) | "{-# LANGUAGE" `T.isPrefixOf` VFS.fullLine pfix- = Completions $ List $ map buildCompletion possiblePragmas+ = Completions $ List $ map buildCompletion+ (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | otherwise = Completions $ List [] result Nothing = Completions $ List []@@ -126,7 +156,7 @@ CompletionItem { _label = p, _kind = Just CiKeyword,- _tags = List [],+ _tags = Nothing, _detail = Nothing, _documentation = Nothing, _deprecated = Nothing,
plugins/hls-eval-plugin/test/Eval.hs view
@@ -147,6 +147,13 @@ , testCase "Prelude has no special treatment, it is imported as stated in the module" $ goldenTest "TPrelude.hs"+ , testCase "Test on last line insert results correctly" $ do+ runSession hlsCommand fullCaps evalPath $+ liftIO $ do+ let mdl = "TLastLine.hs"+ -- Write the test file, to make sure that it has no final line return+ writeFile (evalPath </> mdl) $ "module TLastLine where\n\n-- >>> take 3 [1..]"+ goldenTest mdl #if __GLASGOW_HASKELL__ >= 808 , testCase "CPP support" $ goldenTest "TCPP.hs" , testCase "Literate Haskell Bird Style" $ goldenTest "TLHS.lhs"@@ -161,11 +168,11 @@ Compare results with the contents of corresponding '.expected' file (and creates it, if missing) -} goldenTestBy :: (CodeLens -> Bool) -> FilePath -> IO ()-goldenTestBy f input = runSession hlsCommand fullCaps evalPath $ do+goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do doc <- openDoc input "haskell" -- Execute lenses backwards, to avoid affecting their position in the source file- codeLenses <- reverse <$> getCodeLensesBy f doc+ codeLenses <- reverse <$> getCodeLensesBy fltr doc -- liftIO $ print codeLenses -- Execute sequentially@@ -180,9 +187,8 @@ -- Write expected file if missing missingExpected <- not <$> doesFileExist expectedFile when missingExpected $ T.writeFile expectedFile edited-- expected <- liftIO $ T.readFile expectedFile- liftIO $ edited @?= expected+ expected <- T.readFile expectedFile+ edited @?= expected getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getEvalCodeLenses = getCodeLensesBy isEvalTest
+ plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}++module Ide.Plugin.Splice.Types where++import Data.Aeson (FromJSON, ToJSON)+import Development.IDE (Uri)+import GHC.Generics (Generic)+import Development.IDE.GHC.Compat (RealSrcSpan)+import qualified Data.Text as T+import Ide.Types ( CommandId )++-- | Parameter for the addMethods PluginCommand.+data ExpandSpliceParams = ExpandSpliceParams+ { uri :: Uri+ , spliceSpan :: RealSrcSpan+ , spliceContext :: SpliceContext+ }+ deriving (Show, Eq, Generic)+ deriving anyclass (ToJSON, FromJSON)++-- FIXME: HsDecl needs different treatment of splicing.+data SpliceContext = Expr | HsDecl | Pat | HsType+ deriving (Read, Show, Eq, Ord, Generic)+ deriving anyclass (ToJSON, FromJSON)++data ExpandStyle = Inplace | Commented+ deriving (Read, Show, Eq, Ord, Generic)++expandStyles :: [(ExpandStyle, (T.Text, CommandId))]+expandStyles =+ [ (Inplace, (inplaceCmdName, expandInplaceId))+ -- , (Commented, commentedCmdName, expandCommentedId)+ ]++toExpandCmdTitle :: ExpandStyle -> T.Text+toExpandCmdTitle Inplace = inplaceCmdName+toExpandCmdTitle Commented = commentedCmdName++toCommandId :: ExpandStyle -> CommandId+toCommandId Inplace = expandInplaceId+toCommandId Commented = expandCommentedId++expandInplaceId, expandCommentedId :: CommandId+expandInplaceId = "expandTHSpliceInplace"+expandCommentedId = "expandTHSpliceCommented"++inplaceCmdName :: T.Text+inplaceCmdName = "expand TemplateHaskell Splice (in-place)"++commentedCmdName :: T.Text+commentedCmdName = "expand TemplateHaskell Splice (comented-out)"
+ plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Ide.Plugin.Tactic.TestTypes where++import qualified Data.Text as T++------------------------------------------------------------------------------+-- | The list of tactics exposed to the outside world. These are attached to+-- actual tactics via 'commandTactic' and are contextually provided to the+-- editor via 'commandProvider'.+data TacticCommand+ = Auto+ | Intros+ | Destruct+ | Homomorphism+ | DestructLambdaCase+ | HomomorphismLambdaCase+ deriving (Eq, Ord, Show, Enum, Bounded)++-- | Generate a title for the command.+tacticTitle :: TacticCommand -> T.Text -> T.Text+tacticTitle Auto _ = "Attempt to fill hole"+tacticTitle Intros _ = "Introduce lambda"+tacticTitle Destruct var = "Case split on " <> var+tacticTitle Homomorphism var = "Homomorphic case split on " <> var+tacticTitle DestructLambdaCase _ = "Lambda case split"+tacticTitle HomomorphismLambdaCase _ = "Homomorphic lambda case split"
− plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Ide.Plugin.Tactic.TestTypes where--import qualified Data.Text as T----------------------------------------------------------------------------------- | The list of tactics exposed to the outside world. These are attached to--- actual tactics via 'commandTactic' and are contextually provided to the--- editor via 'commandProvider'.-data TacticCommand- = Auto- | Intros- | Destruct- | Homomorphism- | DestructLambdaCase- | HomomorphismLambdaCase- deriving (Eq, Ord, Show, Enum, Bounded)---- | Generate a title for the command.-tacticTitle :: TacticCommand -> T.Text -> T.Text-tacticTitle Auto _ = "Attempt to fill hole"-tacticTitle Intros _ = "Introduce lambda"-tacticTitle Destruct var = "Case split on " <> var-tacticTitle Homomorphism var = "Homomorphic case split on " <> var-tacticTitle DestructLambdaCase _ = "Lambda case split"-tacticTitle HomomorphismLambdaCase _ = "Homomorphic lambda case split"
src/Ide/Main.hs view
@@ -1,11 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} -- To get precise GHC version-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -55,7 +51,7 @@ import System.IO import qualified System.Log.Logger as L import System.Time.Extra-import Development.Shake (action)+import Development.Shake (ShakeOptions (shakeThreads), action) ghcIdePlugins :: T.Text -> IdePlugins IdeState -> (Plugin Config, [T.Text]) ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps)@@ -131,14 +127,13 @@ hPutStrLn stderr $ "Started LSP server in " ++ showDuration t sessionLoader <- loadSession dir -- config <- fromMaybe defaultLspConfig <$> getConfig- let options = (defaultIdeOptions sessionLoader)+ let options = defOptions { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling , optTesting = IdeTesting argsTesting- , optThreads = argsThreads- -- , optCheckParents = checkParents config- -- , optCheckProject = checkProject config+ , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads} }+ defOptions = defaultIdeOptions sessionLoader debouncer <- newAsyncDebouncer initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event wProg wIndefProg hlsLogger debouncer options vfs
src/Ide/Version.hs view
@@ -49,7 +49,7 @@ ] where showVersionWithDefault :: Maybe Version -> String- showVersionWithDefault = maybe ("Not found") showVersion+ showVersionWithDefault = maybe "Not found" showVersion findProgramVersions :: IO ProgramsOfInterest findProgramVersions = ProgramsOfInterest@@ -67,7 +67,7 @@ Just path -> readProcessWithExitCode path ["--numeric-version"] "" >>= \case (ExitSuccess, sout, _) -> pure $ consumeParser myVersionParser sout- _ -> pure $ Nothing+ _ -> pure Nothing where myVersionParser = do skipSpaces
test/functional/Class.hs view
@@ -32,6 +32,7 @@ @?= [ Just "Add placeholders for '=='" , Just "Add placeholders for '/='"+ , Just "Disable \"missing-methods\" warnings" ] , glodenTest "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do@@ -48,6 +49,9 @@ , glodenTest "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do executeCodeAction mmAction+ , glodenTest "Creates a placeholder for a method starting with '_'" "T4" ""+ $ \(_fAction:_) -> do+ executeCodeAction _fAction ] _CACodeAction :: Prism' CAResult CodeAction@@ -60,7 +64,7 @@ glodenTest :: String -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree glodenTest name fp deco execute- = goldenVsStringDiff name goldenGitDiff (classPath </> fp <.> deco <.> "expected" <.> "hs")+ = goldenVsStringDiff name goldenGitDiff (classPath </> fpWithDeco <.> "expected" <.> "hs") $ runSession hlsCommand fullCaps classPath $ do doc <- openDoc (fp <.> "hs") "haskell"@@ -68,6 +72,10 @@ actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc execute actions BS.fromStrict . T.encodeUtf8 <$> getDocumentEdit doc+ where+ fpWithDeco+ | deco == "" = fp+ | otherwise = fp <.> deco goldenGitDiff :: FilePath -> FilePath -> [String] goldenGitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]
test/functional/Command.hs view
@@ -11,10 +11,7 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit-import Test.Tasty.ExpectedFailure (ignoreTestBecause) ----TODO : Response Message no longer has 4 inputs tests :: TestTree tests = testGroup "commands" [ testCase "are prefixed" $@@ -25,13 +22,13 @@ liftIO $ do all f cmds @? "All prefixed" not (null cmds) @? "Commands aren't empty"- , ignoreTestBecause "Broken: Plugin package doesn't exist" $- testCase "get de-prefixed" $+ , testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request WorkspaceExecuteCommand- (ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse+ (ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse let ResponseError _ msg _ = err- -- We expect an error message about the dud arguments, but should pickup "add" and "package"- liftIO $ (msg `T.isInfixOf` "while parsing args for add in plugin package") @? "Has error message"+ -- We expect an error message about the dud arguments, but we can+ -- check that we found the right plugin.+ liftIO $ "while parsing args for evalCommand in plugin eval" `T.isInfixOf` msg @? "Has error message" ]
test/functional/Completion.hs view
@@ -13,7 +13,8 @@ import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit import qualified Data.Text as T-import System.Time.Extra (sleep)+import Data.Default (def)+import Ide.Plugin.Config (Config (maxCompletions)) tests :: TestTree tests = testGroup "completions" [@@ -54,12 +55,12 @@ , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - liftIO $ sleep 4+ _ <- waitForDiagnostics let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" _ <- applyEdit doc te - compls <- getCompletions doc (Position 1 22)+ compls <- getCompletions doc (Position 1 23) let item = head $ filter ((== "Maybe") . (^. label)) compls liftIO $ do item ^. label @?= "Maybe"@@ -69,22 +70,22 @@ , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - liftIO $ sleep 4+ _ <- waitForDiagnostics - let te = TextEdit (Range (Position 2 17) (Position 1 25)) "Dat"+ let te = TextEdit (Range (Position 2 17) (Position 2 25)) "Data.L" _ <- applyEdit doc te - compls <- getCompletions doc (Position 1 19)- let item = head $ filter ((== "Data.List") . (^. label)) compls+ compls <- getCompletions doc (Position 2 24)+ let item = head $ filter ((== "List") . (^. label)) compls liftIO $ do- item ^. label @?= "Data.List"+ item ^. label @?= "List" item ^. detail @?= Just "Data.List" item ^. kind @?= Just CiModule , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - liftIO $ sleep 4+ _ <- waitForDiagnostics let te = TextEdit (Range (Position 0 24) (Position 0 31)) "" _ <- applyEdit doc te@@ -95,10 +96,38 @@ item ^. label @?= "OverloadedStrings" item ^. kind @?= Just CiKeyword + , testCase "completes the Strict language extension" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do+ doc <- openDoc "Completion.hs" "haskell"++ _ <- waitForDiagnostics++ let te = TextEdit (Range (Position 0 13) (Position 0 31)) "Str"+ _ <- applyEdit doc te++ compls <- getCompletions doc (Position 0 16)+ let item = head $ filter ((== "Strict") . (^. label)) compls+ liftIO $ do+ item ^. label @?= "Strict"+ item ^. kind @?= Just CiKeyword++ , testCase "completes No- language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do+ doc <- openDoc "Completion.hs" "haskell"++ _ <- waitForDiagnostics++ let te = TextEdit (Range (Position 0 13) (Position 0 31)) "NoOverload"+ _ <- applyEdit doc te++ compls <- getCompletions doc (Position 0 23)+ let item = head $ filter ((== "NoOverloadedStrings") . (^. label)) compls+ liftIO $ do+ item ^. label @?= "NoOverloadedStrings"+ item ^. kind @?= Just CiKeyword+ , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - liftIO $ sleep 4+ _ <- waitForDiagnostics let te = TextEdit (Range (Position 0 4) (Position 0 34)) "" _ <- applyEdit doc te@@ -128,7 +157,7 @@ , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - liftIO $ sleep 4+ _ <- waitForDiagnostics let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS" _ <- applyEdit doc te@@ -159,7 +188,7 @@ doc <- openDoc "Completion.hs" "haskell" compls <- getCompletions doc (Position 5 7)- liftIO $ any ((== "!!") . (^. label)) compls @? ""+ liftIO $ assertBool "Expected completions" $ not $ null compls -- See https://github.com/haskell/haskell-ide-engine/issues/903 , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do@@ -194,6 +223,12 @@ liftIO $ item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c" + , testCase "maxCompletions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do+ doc <- openDoc "Completion.hs" "haskell"++ compls <- getCompletions doc (Position 5 7)+ liftIO $ length compls @?= maxCompletions def+ , contextTests , snippetTests ]@@ -296,11 +331,10 @@ item ^. insertTextFormat @?= Just Snippet item ^. insertText @?= Just "intersperse ${1:a} ${2:[a]}" - , ignoreTestBecause "ghcide does not support the completionSnippetsOn option" $- testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do+ , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" - let config = object [ "haskell" .= (object ["completionSnippetsOn" .= False])]+ let config = object [ "haskell" .= object ["completionSnippetsOn" .= False]] sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams config)@@ -350,7 +384,7 @@ , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - compls <- getCompletions doc (Position 3 9)+ compls <- getCompletions doc (Position 3 10) liftIO $ do compls `shouldContainCompl` "abs" compls `shouldNotContainCompl` "Applicative"
test/functional/Diagnostic.hs view
@@ -6,9 +6,7 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson (toJSON)-import qualified Data.Text as T import qualified Data.Default-import Ide.Logger import Ide.Plugin.Config import Language.Haskell.LSP.Test hiding (message) import Language.Haskell.LSP.Types@@ -22,72 +20,53 @@ tests :: TestTree tests = testGroup "diagnostics providers" [- saveTests- , triggerTests- , errorTests+ basicTests+ , saveTests , warningTests ] --triggerTests :: TestTree-triggerTests = testGroup "diagnostics triggers" [- ignoreTestBecause "Broken" $- ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $- runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do- logm "starting DiagnosticSpec.runs diagnostic on save"+basicTests :: TestTree+basicTests = testGroup "Diagnostics work" [+ testCase "hlint produces diagnostics" $+ runSession hlsCommand fullCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell"-- diags@(reduceDiag:_) <- waitForDiagnostics-+ diags <- waitForDiagnosticsFromSource doc "hlint"+ reduceDiag <- liftIO $ inspectDiagnostic diags ["Eta reduce"]+ redundantID <- liftIO $ inspectDiagnostic diags ["Redundant id"] liftIO $ do length diags @?= 2 reduceDiag ^. LSP.range @?= Range (Position 1 0) (Position 1 12) reduceDiag ^. LSP.severity @?= Just DsInfo- reduceDiag ^. LSP.code @?= Just (StringValue "Eta reduce")- reduceDiag ^. LSP.source @?= Just "hlint"-- diags2a <- waitForDiagnostics-- liftIO $ length diags2a @?= 2-- sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)-- diags3@(d:_) <- waitForDiagnosticsSource "eg2"+ redundantID ^. LSP.severity @?= Just DsInfo + , testCase "example plugin produces diagnostics" $+ runSession hlsCommandExamplePlugin fullCaps "test/testdata/hlint" $ do+ doc <- openDoc "ApplyRefact2.hs" "haskell"+ diags <- waitForDiagnosticsFromSource doc "example2"+ reduceDiag <- liftIO $ inspectDiagnostic diags ["example2 diagnostic, hello world"] liftIO $ do- length diags3 @?= 1- d ^. LSP.range @?= Range (Position 0 0) (Position 1 0)- d ^. LSP.severity @?= Nothing- d ^. LSP.code @?= Nothing- d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"- ]--errorTests :: TestTree-errorTests = testGroup "typed hole errors" [- ignoreTestBecause "Broken" $ testCase "is deferred" $- runSession hlsCommand fullCaps "test/testdata" $ do- _ <- openDoc "TypedHoles.hs" "haskell"- [diag] <- waitForDiagnosticsSource "bios"- liftIO $ diag ^. LSP.severity @?= Just DsWarning+ length diags @?= 1+ reduceDiag ^. LSP.range @?= Range (Position 0 0) (Position 1 0)+ reduceDiag ^. LSP.severity @?= Just DsError ] warningTests :: TestTree warningTests = testGroup "Warnings are warnings" [- ignoreTestBecause "Broken" $ testCase "Overrides -Werror" $+ testCase "Overrides -Werror" $ runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do- _ <- openDoc "src/WError.hs" "haskell"- [diag] <- waitForDiagnosticsSource "bios"+ doc <- openDoc "src/WError.hs" "haskell"+ [diag] <- waitForDiagnosticsFrom doc liftIO $ diag ^. LSP.severity @?= Just DsWarning ] saveTests :: TestTree saveTests = testGroup "only diagnostics on save" [- ignoreTestBecause "Broken" $ testCase "Respects diagnosticsOnChange setting" $+ ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $ runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do let config = Data.Default.def { diagnosticsOnChange = False } :: Config sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "Hover.hs" "haskell"- diags <- waitForDiagnostics+ diags <- waitForDiagnosticsFrom doc liftIO $ do length diags @?= 0@@ -97,7 +76,7 @@ skipManyTill loggingNotification noDiagnostics sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)- diags2 <- waitForDiagnostics+ diags2 <- waitForDiagnosticsFrom doc liftIO $ length diags2 @?= 1 ]
test/functional/FunctionalBadProject.hs view
@@ -24,7 +24,6 @@ -- testCase "deals with cabal file with unsatisfiable dependency" $ -- runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata/badProjects/cabal" $ do- -- -- runSessionWithConfig logConfig hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do -- _doc <- openDoc "Foo.hs" "haskell" -- diags@(d:_) <- waitForDiagnosticsSource "bios"
test/functional/FunctionalCodeAction.hs view
@@ -83,6 +83,36 @@ contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo = id\n" + , testCase "changing configuration enables or disables hlint diagnostics" $ runHlintSession "" $ do+ let config = def { hlintOn = True }+ sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config))++ doc <- openDoc "ApplyRefact2.hs" "haskell"+ testHlintDiagnostics doc++ let config' = def { hlintOn = False }+ sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config'))++ diags' <- waitForDiagnosticsFrom doc++ liftIO $ noHlintDiagnostics diags'++ , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do+ doc <- openDoc "ApplyRefact2.hs" "haskell"+ testHlintDiagnostics doc++ let change = TextDocumentContentChangeEvent+ (Just (Range (Position 1 8) (Position 1 12)))+ Nothing "x"+ changeDoc doc [change]+ expectNoMoreDiagnostics 3 doc "hlint"++ let change' = TextDocumentContentChangeEvent+ (Just (Range (Position 1 8) (Position 1 12)))+ Nothing "id x"+ changeDoc doc [change']+ testHlintDiagnostics doc+ , knownBrokenForGhcVersions [GHC88, GHC86] "hlint doesn't take in account cpp flag as ghc -D argument" $ testCase "hlint diagnostics works with CPP via ghc -XCPP argument (#554)" $ runHlintSession "cpp" $ do doc <- openDoc "ApplyRefact3.hs" "haskell"@@ -97,11 +127,14 @@ doc <- openDoc "ApplyRefact2.hs" "haskell" testHlintDiagnostics doc - , knownBrokenForGhcVersions [GHC88, GHC86] "apply-refact doesn't take in account the -X argument" $- testCase "apply-refact works with LambdaCase via ghc -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do+ , testCase "apply-refact works with -XLambdaCase argument (#590)" $ runHlintSession "lambdacase" $ do testRefactor "ApplyRefact1.hs" "Redundant bracket" expectedLambdaCase + , testCase "apply-refact works with -XTypeApplications argument (#1242)" $ runHlintSession "typeapps" $ do+ testRefactor "ApplyRefact1.hs" "Redundant bracket"+ expectedTypeApp+ , testCase "apply hints works with LambdaCase via language pragma" $ runHlintSession "" $ do testRefactor "ApplyRefact1.hs" "Redundant bracket" ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)@@ -128,12 +161,19 @@ testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do doc <- openDoc "ApplyRefact5.hs" "haskell" expectNoMoreDiagnostics 3 doc "hlint"++ , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do+ testRefactor "ApplyRefact6.hs" "Redundant bracket" expectedComments ] where runHlintSession :: FilePath -> Session a -> IO a runHlintSession subdir = failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata/hlint" </> subdir) + noHlintDiagnostics :: [Diagnostic] -> Assertion+ noHlintDiagnostics diags =+ Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"+ testHlintDiagnostics doc = do diags <- waitForDiagnosticsFromSource doc "hlint" liftIO $ length diags > 0 @? "There are hlint diagnostics"@@ -162,7 +202,17 @@ , "g = 2" , "#endif", "" ]-+ expectedComments = [ "-- comment before header"+ , "module ApplyRefact6 where", ""+ , "{-# standalone annotation #-}", ""+ , "-- standalone comment", ""+ , "-- | haddock comment"+ , "f = {- inline comment -}{- inline comment inside refactored code -} 1 -- ending comment", ""+ , "-- final comment"+ ]+ expectedTypeApp = [ "module ApplyRefact1 where", ""+ , "a = id @Int 1"+ ] renameTests :: TestTree renameTests = testGroup "rename suggestions" [ testCase "works" $ runSession hlsCommand noLiteralCaps "test/testdata" $ do@@ -323,10 +373,10 @@ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck"- CACommand cmd : _ <- getAllCodeActions doc+ _ : CACommand cmd : _ <- getAllCodeActions doc executeCommand cmd contents <- documentContents doc- liftIO $ (T.lines contents) @?=+ liftIO $ T.lines contents @?= [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module MultipleImports where" , "import Data.Maybe"@@ -391,7 +441,7 @@ _ <- waitForDiagnosticsFromSource doc "typecheck" cas <- map fromAction <$> getAllCodeActions doc - liftIO $ "add signature: main :: IO ()" `elem` (map (^. L.title) cas) @? "Contains code action"+ liftIO $ "add signature: main :: IO ()" `elem` map (^. L.title) cas @? "Contains code action" executeCodeAction $ head cas @@ -405,7 +455,7 @@ , " return ()" ] - liftIO $ (T.lines contents) @?= expected+ liftIO $ T.lines contents @?= expected ] missingPragmaTests :: TestTree@@ -425,6 +475,7 @@ contents <- documentContents doc let expected = [ "{-# LANGUAGE TypeSynonymInstances #-}"+ , "module NeedsPragmas where" , "" , "import GHC.Generics" , ""@@ -442,7 +493,31 @@ , " deriving (Generic,Functor,Traversable)" ] - liftIO $ (T.lines contents) @?= expected+ liftIO $ T.lines contents @?= expected++ , testCase "Adds TypeApplications pragma" $ do+ runSession hlsCommand fullCaps "test/testdata/addPragmas" $ do+ doc <- openDoc "TypeApplications.hs" "haskell"++ _ <- waitForDiagnosticsFrom doc+ cas <- map fromAction <$> getAllCodeActions doc++ liftIO $ "Add \"TypeApplications\"" `elem` map (^. L.title) cas @? "Contains TypeApplications code action"++ executeCodeAction $ head cas++ contents <- documentContents doc++ let expected =+ [ "{-# LANGUAGE TypeApplications #-}"+ , "{-# LANGUAGE ScopedTypeVariables #-}"+ , "module TypeApplications where"+ , ""+ , "foo :: forall a. a -> a"+ , "foo = id @a"+ ]++ liftIO $ T.lines contents @?= expected ] unusedTermTests :: TestTree@@ -475,15 +550,24 @@ doc <- openDoc "CodeActionOnly.hs" "haskell" _ <- waitForDiagnosticsFrom doc diags <- getCurrentDiagnostics doc- let params = CodeActionParams doc (Range (Position 2 10) (Position 4 0)) caContext Nothing+ let params = CodeActionParams doc (Range (Position 1 0) (Position 4 0)) caContext Nothing caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline]))+ caContextAllActions = CodeActionContext (List diags) Nothing+ -- Verify that we get code actions of at least two different kinds.+ ResponseMessage _ _ (Right (List allCodeActions))+ <- request TextDocumentCodeAction (params & L.context .~ caContextAllActions)+ liftIO $ do+ redundantId <- inspectCodeAction allCodeActions ["Redundant id"]+ redundantId ^. L.kind @?= Just CodeActionQuickFix+ unfoldFoo <- inspectCodeAction allCodeActions ["Unfold foo"]+ unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline+ -- Verify that that when we set the only parameter, we only get actions+ -- of the right kind. ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params let cas = map fromAction res kinds = map (^. L.kind) cas liftIO $ do- -- TODO: When HaRe is back this should be uncommented- -- kinds `shouldNotSatisfy` null- not (any (Just CodeActionRefactorInline /=) kinds) @? "None not CodeActionRefactorInline"+ not (null kinds) @? "We found an action of kind RefactorInline" all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ]
test/functional/FunctionalLiquid.hs view
@@ -6,7 +6,6 @@ import Control.Monad.IO.Class import Data.Aeson import Data.Default-import qualified Data.Text as T import Language.Haskell.LSP.Test hiding (message) import Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Types.Lens as LSP hiding (contents)@@ -20,83 +19,19 @@ tests :: TestTree tests = testGroup "liquid haskell diagnostics" [- ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, no liquid" $- runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do- doc <- openDoc "liquid/Evens.hs" "haskell"-- diags@(reduceDiag:_) <- waitForDiagnostics-- liftIO $ do- length diags @?= 2- reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22)- reduceDiag ^. severity @?= Just DsHint- reduceDiag ^. code @?= Just (StringValue "Use negate")- reduceDiag ^. source @?= Just "hlint"-- diags2hlint <- waitForDiagnostics-- liftIO $ length diags2hlint @?= 2-- sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)-- diags3@(d:_) <- waitForDiagnosticsSource "eg2"-- liftIO $ do- length diags3 @?= 1- d ^. LSP.range @?= Range (Position 0 0) (Position 1 0)- d ^. LSP.severity @?= Nothing- d ^. LSP.code @?= Nothing- d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave"-- -- ----------------------------------- , ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, with liquid haskell" $+ ignoreTestBecause "no liquid haskell"+ $ testCase "liquid haskell generates diagnostics" $ runSession hlsCommand codeActionSupportCaps "test/testdata" $ do- -- runSessionWithConfig logConfig hlsCommand codeActionSupportCaps "test/testdata" $ do doc <- openDoc "liquid/Evens.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnostics-- -- liftIO $ show diags @?= ""-- liftIO $ do- length diags @?= 2- reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22)- reduceDiag ^. severity @?= Just DsHint- reduceDiag ^. code @?= Just (StringValue "Use negate")- reduceDiag ^. source @?= Just "hlint"-- -- Enable liquid haskell plugin and disable hlint let config = def { liquidOn = True, hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - -- docItem <- getDocItem file languageId- sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc)- -- TODO: what does that test?- -- TODO: whether hlint is really disbabled?- -- TODO: @fendor, document or remove- -- diags2hlint <- waitForDiagnostics- -- -- liftIO $ show diags2hlint @?= ""-- -- -- We turned hlint diagnostics off- -- liftIO $ length diags2hlint @?= 0- -- diags2liquid <- waitForDiagnostics- -- liftIO $ length diags2liquid @?= 0- -- liftIO $ show diags2liquid @?= ""- diags3@(d:_) <- waitForDiagnosticsSource "liquid"- -- liftIO $ show diags3 @?= ""+ diags <- waitForDiagnosticsFromSource doc "liquid"+ d <- liftIO $ inspectDiagnostic diags ["Liquid Type Mismatch"] liftIO $ do- length diags3 @?= 1+ length diags @?= 1 d ^. range @?= Range (Position 8 0) (Position 8 11) d ^. severity @?= Just DsError d ^. code @?= Nothing- d ^. source @?= Just "liquid"- (d ^. message) `T.isPrefixOf`- ("Error: Liquid Type Mismatch\n" <>- " Inferred type\n" <>- " VV : {v : GHC.Types.Int | v == 7}\n" <>- " \n" <>- " not a subtype of Required type\n" <>- " VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ")- @? "Contains error message" ]
+ test/functional/HaddockComments.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module HaddockComments+ ( tests,+ )+where++import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString.Lazy as LBS+import Data.Foldable (find)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Types+import System.FilePath ((<.>), (</>))+import Test.Hls.Util+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "haddock comments"+ [ goldenTest "HigherRankFunction" Signature 4 6,+ goldenTest "KindSigFunction" Signature 9 10,+ goldenTest "MultivariateFunction" Signature 4 8,+ goldenTest "QualFunction" Signature 2 10,+ goldenTest "Record" Record 7 2,+ expectedNothing "ConstFunction" Signature 2 2,+ expectedNothing "StaleFunction" Signature 3 3,+ expectedNothing "StaleRecord" Record 3 12+ ]++goldenTest :: FilePath -> GenCommentsType -> Int -> Int -> TestTree+goldenTest fp (toTitle -> expectedTitle) l c = goldenVsStringDiff (fp <> " (golden)") goldenGitDiff goldenFilePath $+ runSession hlsCommand fullCaps haddockCommentsPath $ do+ doc <- openDoc hsFilePath "haskell"+ _ <- waitForDiagnostics+ actions <- getCodeActions doc (Range (Position l c) (Position l $ succ c))+ case find ((== Just expectedTitle) . caTitle) actions of+ Just (CACodeAction x) -> do+ executeCodeAction x+ LBS.fromStrict . encodeUtf8 <$> documentContents doc+ _ -> liftIO $ assertFailure "Unable to find CodeAction"+ where+ hsFilePath = fp <.> "hs"+ goldenFilePath = haddockCommentsPath </> fp <.> "expected" <.> "hs"++expectedNothing :: FilePath -> GenCommentsType -> Int -> Int -> TestTree+expectedNothing fp (toTitle -> expectedTitle) l c = testCase fp $+ runSession hlsCommand fullCaps haddockCommentsPath $ do+ doc <- openDoc (fp <.> "hs") "haskell"+ _ <- waitForDiagnostics+ titles <- mapMaybe caTitle <$> getCodeActions doc (Range (Position l c) (Position l $ succ c))+ liftIO $ expectedTitle `notElem` titles @? "Unexpected CodeAction"++data GenCommentsType = Signature | Record++toTitle :: GenCommentsType -> Text+toTitle Signature = "Generate signature comments"+toTitle Record = "Generate fields comments"++caTitle :: CAResult -> Maybe Text+caTitle (CACodeAction CodeAction {_title}) = Just _title+caTitle _ = Nothing++haddockCommentsPath :: String+haddockCommentsPath = "test" </> "testdata" </> "haddockComments"++goldenGitDiff :: FilePath -> FilePath -> [String]+goldenGitDiff fRef fNew = ["git", "diff", "--no-index", "--text", "--exit-code", fRef, fNew]
test/functional/HieBios.hs view
@@ -1,36 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} module HieBios (tests) where -import Control.Applicative.Combinators+import Control.Lens ((^.))+import Control.Monad.IO.Class import qualified Data.Text as T import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Messages+import qualified Language.Haskell.LSP.Types.Lens as L import System.FilePath ((</>)) import Test.Hls.Util import Test.Tasty-import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit tests :: TestTree tests = testGroup "hie-bios" [- ignoreTestBecause "Broken" $ testCase "loads modules inside main-is" $ do+ testCase "loads modules inside main-is" $ do writeFile (hieBiosErrorPath </> "hie.yaml") "" runSession hlsCommand fullCaps "test/testdata/hieBiosMainIs" $ do- _ <- openDoc "Main.hs" "haskell"- _ <- count 2 waitForDiagnostics- return ()+ doc <- openDoc "Main.hs" "haskell"+ Just mainHoverText <- getHover doc (Position 3 1)+ let (HoverContents (MarkupContent _ x)) = mainHoverText ^. L.contents+ liftIO $ "main :: IO ()" `T.isInfixOf` x+ @? "found hover text for main" - , ignoreTestBecause "Broken" $ testCase "reports errors in hie.yaml" $ do+ , testCase "reports errors in hie.yaml" $ do writeFile (hieBiosErrorPath </> "hie.yaml") "" runSession hlsCommand fullCaps hieBiosErrorPath $ do _ <- openDoc "Foo.hs" "haskell"- _ <- skipManyTill loggingNotification (satisfy isMessage)- return ()+ (diag:_) <- waitForDiagnostics+ liftIO $ "Expected a cradle: key containing the preferences" `T.isInfixOf` (diag ^. L.message)+ @? "Error reported" ] where hieBiosErrorPath = "test/testdata/hieBiosError"-- isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) =- "Couldn't parse hie.yaml" `T.isInfixOf` s- isMessage _ = False
test/functional/Main.hs view
@@ -12,6 +12,7 @@ import FunctionalBadProject import FunctionalCodeAction import FunctionalLiquid+import HaddockComments import HieBios import Highlight import ModuleName@@ -19,6 +20,7 @@ import Reference import Rename import Symbol+import Splice import Tactic import Test.Tasty import Test.Tasty.Ingredients.Rerun@@ -58,4 +60,6 @@ , Symbol.tests , Tactic.tests , TypeDefinition.tests+ , Splice.tests+ , HaddockComments.tests ]
test/functional/ModuleName.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}
test/functional/Rename.hs view
@@ -1,27 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} module Rename (tests) where --- import Control.Monad.IO.Class--- import Language.Haskell.LSP.Test--- import Language.Haskell.LSP.Types--- import Test.Hls.Util+import Control.Monad.IO.Class (liftIO)+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Types+import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.ExpectedFailure (ignoreTestBecause) tests :: TestTree tests = testGroup "rename" [- testCase "works" $ True @?= True- -- pendingWith "removed because of HaRe"- -- runSession hlsCommand fullCaps "test/testdata" $ do- -- doc <- openDoc "Rename.hs" "haskell"- -- rename doc (Position 3 1) "baz" -- foo :: Int -> Int- -- documentContents doc >>= liftIO . flip shouldBe expected- -- where- -- expected =- -- "main = do\n\- -- \ x <- return $ baz 42\n\- -- \ return (baz x)\n\- -- \baz :: Int -> Int\n\- -- \baz x = x + 1\n\- -- \bar = (+ 1) . baz\n"+ ignoreTestBecause "no symbol renaming (yet!)" $+ testCase "works" $+ runSession hlsCommand fullCaps "test/testdata/rename" $ do+ doc <- openDoc "Rename.hs" "haskell"+ rename doc (Position 3 1) "baz" -- foo :: Int -> Int+ contents <- documentContents doc+ let expected =+ "main = do\n\+ \ x <- return $ baz 42\n\+ \ return (baz x)\n\+ \baz :: Int -> Int\n\+ \baz x = x + 1\n\+ \bar = (+ 1) . baz\n"+ liftIO $ contents @?= expected ]
+ test/functional/Splice.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}++module Splice (tests) where++import Control.Applicative.Combinators+import Control.Monad+import Control.Monad.IO.Class+import Data.List (find)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Ide.Plugin.Splice.Types+import Language.Haskell.LSP.Test+import Language.Haskell.LSP.Types+ ( ApplyWorkspaceEditRequest,+ CAResult (..),+ CodeAction (..),+ Position (..),+ Range (..),+ TextDocumentContentChangeEvent (..),+ TextEdit (..),+ )+import System.Directory+import System.FilePath+import System.Time.Extra (sleep)+import Test.Hls.Util+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "splice"+ [ goldenTest "TSimpleExp.hs" Inplace 6 15+ , goldenTest "TSimpleExp.hs" Inplace 6 24+ , goldenTest "TTypeAppExp.hs" Inplace 7 5+ , goldenTest "TErrorExp.hs" Inplace 6 15+ , goldenTest "TErrorExp.hs" Inplace 6 51+ , goldenTest "TQQExp.hs" Inplace 6 17+ , goldenTest "TQQExp.hs" Inplace 6 25+ , goldenTest "TQQExpError.hs" Inplace 6 13+ , goldenTest "TQQExpError.hs" Inplace 6 22+ , testGroup "Pattern Splices"+ [ goldenTest "TSimplePat.hs" Inplace 6 3+ , goldenTest "TSimplePat.hs" Inplace 6 22+ , goldenTest "TSimplePat.hs" Inplace 6 3+ , goldenTest "TSimplePat.hs" Inplace 6 22+ , goldenTest "TErrorPat.hs" Inplace 6 3+ , goldenTest "TErrorPat.hs" Inplace 6 18+ , goldenTest "TQQPat.hs" Inplace 6 3+ , goldenTest "TQQPat.hs" Inplace 6 11+ , goldenTest "TQQPatError.hs" Inplace 6 3+ , goldenTest "TQQPatError.hs" Inplace 6 11+ ]+ , goldenTest "TSimpleType.hs" Inplace 5 12+ , goldenTest "TSimpleType.hs" Inplace 5 22+ , goldenTest "TTypeTypeError.hs" Inplace 7 12+ , goldenTest "TTypeTypeError.hs" Inplace 7 52+ , goldenTest "TQQType.hs" Inplace 8 19+ , goldenTest "TQQType.hs" Inplace 8 28+ , goldenTest "TQQTypeTypeError.hs" Inplace 8 19+ , goldenTest "TQQTypeTypeError.hs" Inplace 8 28+ , goldenTest "TSimpleDecl.hs" Inplace 8 1+ , goldenTest "TQQDecl.hs" Inplace 5 1+ , goldenTestWithEdit "TTypeKindError.hs" Inplace 7 9+ , goldenTestWithEdit "TDeclKindError.hs" Inplace 8 1+ ]++goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree+goldenTest input tc line col =+ testCase (input <> " (golden)") $ do+ runSession hlsCommand fullCaps spliceTestPath $ do+ doc <- openDoc input "haskell"+ _ <- waitForDiagnostics+ actions <- getCodeActions doc $ pointRange line col+ case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of+ Just (CACodeAction CodeAction {_command = Just c}) -> do+ executeCommand c+ _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message+ edited <- documentContents doc+ let expected_name = spliceTestPath </> input <.> "expected"+ -- Write golden tests if they don't already exist+ liftIO $+ (doesFileExist expected_name >>=) $+ flip unless $ do+ T.writeFile expected_name edited+ expected <- liftIO $ T.readFile expected_name+ liftIO $ edited @?= expected+ _ -> liftIO $ assertFailure "No CodeAction detected"++goldenTestWithEdit :: FilePath -> ExpandStyle -> Int -> Int -> TestTree+goldenTestWithEdit input tc line col =+ testCase (input <> " (golden)") $ do+ runSession hlsCommand fullCaps spliceTestPath $ do+ doc <- openDoc input "haskell"+ orig <- documentContents doc+ let lns = T.lines orig+ theRange =+ Range+ { _start = Position 0 0+ , _end = Position (length lns + 1) 1+ }+ liftIO $ sleep 3+ alt <- liftIO $ T.readFile (spliceTestPath </> input <.> "error")+ void $ applyEdit doc $ TextEdit theRange alt+ changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt]+ void waitForDiagnostics+ actions <- getCodeActions doc $ pointRange line col+ case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of+ Just (CACodeAction CodeAction {_command = Just c}) -> do+ executeCommand c+ _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message+ edited <- documentContents doc+ let expected_name = spliceTestPath </> input <.> "expected"+ -- Write golden tests if they don't already exist+ liftIO $+ (doesFileExist expected_name >>=) $+ flip unless $ do+ T.writeFile expected_name edited+ expected <- liftIO $ T.readFile expected_name+ liftIO $ edited @?= expected+ _ -> liftIO $ assertFailure "No CodeAction detected"++spliceTestPath :: FilePath+spliceTestPath = "test/testdata/splice"++pointRange :: Int -> Int -> Range+pointRange+ (subtract 1 -> line)+ (subtract 1 -> col) =+ Range (Position line col) (Position line $ col + 1)++-- | Get the title of a code action.+codeActionTitle :: CAResult -> Maybe Text+codeActionTitle CACommand {} = Nothing+codeActionTitle (CACodeAction (CodeAction title _ _ _ _)) = Just title
test/functional/Tactic.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}@@ -154,7 +153,7 @@ doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col- Just (CACodeAction (CodeAction {_command = Just c}))+ Just (CACodeAction CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c _resp :: ApplyWorkspaceEditRequest <- skipManyTill anyMessage message@@ -174,7 +173,7 @@ doc <- openDoc input "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col- Just (CACodeAction (CodeAction {_command = Just c}))+ Just (CACodeAction CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions resp <- executeCommandWithResp c liftIO $ unless (isLeft $ _result resp) $@@ -190,4 +189,3 @@ let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams (cmd ^. command) args Nothing request WorkspaceExecuteCommand execParams-
test/utils/Test/Hls/Util.hs view
@@ -20,14 +20,11 @@ , inspectCommand , inspectDiagnostic , knownBrokenForGhcVersions- , logConfig , logFilePath- , noLogConfig , setupBuildToolFiles , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout- , withFileLogging , withCurrentDirectoryInTmp ) where@@ -52,7 +49,6 @@ import System.Environment import System.Time.Extra (Seconds, sleep) import System.FilePath-import qualified System.Log.Logger as L import System.IO.Temp import System.IO.Unsafe import Test.Hspec.Runner@@ -63,34 +59,12 @@ import Text.Blaze.Renderer.String (renderMarkup) import Text.Blaze.Internal hiding (null) --noLogConfig :: Test.SessionConfig-noLogConfig = Test.defaultConfig { Test.logMessages = False }--logConfig :: Test.SessionConfig-logConfig = Test.defaultConfig { Test.logMessages = True }- codeActionSupportCaps :: C.ClientCapabilities codeActionSupportCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } codeActionCaps = C.CodeActionClientCapabilities (Just True) (Just literalSupport) literalSupport = C.CodeActionLiteralSupport def--withFileLogging :: FilePath -> IO a -> IO a-withFileLogging logFile f = do- let logDir = "./test-logs"- logPath = logDir </> logFile-- dirExists <- doesDirectoryExist logDir- unless dirExists $ createDirectory logDir-- exists <- doesFileExist logPath- when exists $ removeFile logPath-- setupLogger (Just logPath) ["hie"] L.DEBUG-- f -- ---------------------------------------------------------------------