diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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: + +![haskell-language-server](https://github.com/haskell/haskell-language-server/raw/master/docs/logos/logo-256.png) + +### 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,13 @@ # haskell-language-server +![haskell-language-server][logo] + [![License Apache 2.0][badge-license]][license] [![CircleCI][badge-circleci]][circleci] +![Github Testing Workflow](https://github.com/haskell/haskell-language-server/workflows/Testing/badge.svg) +![Github Nix Workflow](https://github.com/haskell/haskell-language-server/workflows/Nix/badge.svg) +[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)): - ![Eval](https://i.imgur.com/bh992sT.gif) + ![Eval Demo](plugins/hls-eval-plugin/demo.gif) - 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 diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -16,7 +16,7 @@ let withExamples = case args of - LspMode (LspArguments{..}) -> argsExamplePlugin - _ -> False + LspMode LspArguments{..} -> argsExamplePlugin + _ -> False defaultMain args (idePlugins withExamples) diff --git a/exe/Plugins.hs b/exe/Plugins.hs --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -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" diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -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 - diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -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 @@ -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: diff --git a/plugins/default/src/Ide/Plugin/Brittany.hs b/plugins/default/src/Ide/Plugin/Brittany.hs --- a/plugins/default/src/Ide/Plugin/Brittany.hs +++ b/plugins/default/src/Ide/Plugin/Brittany.hs @@ -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] diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -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 diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -206,7 +206,7 @@ command xd label = "Example2 completion" kind = Nothing - tags = List [] + tags = Nothing detail = Nothing documentation = Nothing deprecated = Nothing diff --git a/plugins/default/src/Ide/Plugin/Floskell.hs b/plugins/default/src/Ide/Plugin/Floskell.hs --- a/plugins/default/src/Ide/Plugin/Floskell.hs +++ b/plugins/default/src/Ide/Plugin/Floskell.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.Floskell ( diff --git a/plugins/default/src/Ide/Plugin/Fourmolu.hs b/plugins/default/src/Ide/Plugin/Fourmolu.hs --- a/plugins/default/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/default/src/Ide/Plugin/Fourmolu.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} module Ide.Plugin.Fourmolu ( diff --git a/plugins/default/src/Ide/Plugin/Ormolu.hs b/plugins/default/src/Ide/Plugin/Ormolu.hs --- a/plugins/default/src/Ide/Plugin/Ormolu.hs +++ b/plugins/default/src/Ide/Plugin/Ormolu.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/plugins/default/src/Ide/Plugin/Pragmas.hs b/plugins/default/src/Ide/Plugin/Pragmas.hs --- a/plugins/default/src/Ide/Plugin/Pragmas.hs +++ b/plugins/default/src/Ide/Plugin/Pragmas.hs @@ -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, diff --git a/plugins/hls-eval-plugin/test/Eval.hs b/plugins/hls-eval-plugin/test/Eval.hs --- a/plugins/hls-eval-plugin/test/Eval.hs +++ b/plugins/hls-eval-plugin/test/Eval.hs @@ -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 diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -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)" diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs @@ -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" diff --git a/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs deleted file mode 100644 --- a/plugins/tactics/src/Ide/Plugin/Tactic/TestTypes.hs +++ /dev/null @@ -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" diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -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 diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -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 diff --git a/test/functional/Class.hs b/test/functional/Class.hs --- a/test/functional/Class.hs +++ b/test/functional/Class.hs @@ -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] diff --git a/test/functional/Command.hs b/test/functional/Command.hs --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -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" ] diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -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" diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -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 ] diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -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" diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -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" ] diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs --- a/test/functional/FunctionalLiquid.hs +++ b/test/functional/FunctionalLiquid.hs @@ -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" ] diff --git a/test/functional/HaddockComments.hs b/test/functional/HaddockComments.hs new file mode 100644 --- /dev/null +++ b/test/functional/HaddockComments.hs @@ -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] diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -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 diff --git a/test/functional/Main.hs b/test/functional/Main.hs --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -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 ] diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs --- a/test/functional/ModuleName.hs +++ b/test/functional/ModuleName.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs --- a/test/functional/Rename.hs +++ b/test/functional/Rename.hs @@ -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 ] diff --git a/test/functional/Splice.hs b/test/functional/Splice.hs new file mode 100644 --- /dev/null +++ b/test/functional/Splice.hs @@ -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 diff --git a/test/functional/Tactic.hs b/test/functional/Tactic.hs --- a/test/functional/Tactic.hs +++ b/test/functional/Tactic.hs @@ -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 - diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -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 -- ---------------------------------------------------------------------