ghcide 0.0.2 → 0.0.3
raw patch · 20 files changed
+1069/−187 lines, 20 filesdep +ghc-libdep +ghc-lib-parserdep ~ghcdep ~hie-biosdep ~shakePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: ghc-lib, ghc-lib-parser
Dependency ranges changed: ghc, hie-bios, shake
API changes (from Hackage documentation)
+ Development.IDE.Types.Options: IdeDefer :: Bool -> IdeDefer
+ Development.IDE.Types.Options: [optDefer] :: IdeOptions -> IdeDefer
+ Development.IDE.Types.Options: newtype IdeDefer
- Development.IDE.Types.Options: IdeOptions :: (ParsedSource -> ([(SrcSpan, String)], ParsedSource)) -> IO (FilePath -> Action HscEnvEq) -> IdePkgLocationOptions -> [String] -> Int -> Maybe FilePath -> IdeReportProgress -> String -> Bool -> IdeOptions
+ Development.IDE.Types.Options: IdeOptions :: (ParsedSource -> ([(SrcSpan, String)], ParsedSource)) -> IO (FilePath -> Action HscEnvEq) -> IdePkgLocationOptions -> [String] -> Int -> Maybe FilePath -> IdeReportProgress -> String -> Bool -> IdeDefer -> IdeOptions
Files
- README.md +180/−0
- exe/Main.hs +15/−4
- ghcide.cabal +37/−8
- include/ghc-api-version.h +10/−0
- src/Development/IDE/Core/Compile.hs +39/−125
- src/Development/IDE/Core/Preprocessor.hs +134/−0
- src/Development/IDE/Core/Rules.hs +2/−1
- src/Development/IDE/Core/Shake.hs +36/−20
- src/Development/IDE/GHC/CPP.hs +5/−4
- src/Development/IDE/GHC/Compat.hs +12/−5
- src/Development/IDE/GHC/Error.hs +17/−0
- src/Development/IDE/GHC/Util.hs +4/−3
- src/Development/IDE/GHC/Warnings.hs +5/−4
- src/Development/IDE/Import/FindImports.hs +9/−2
- src/Development/IDE/LSP/CodeAction.hs +147/−6
- src/Development/IDE/Spans/Calculate.hs +2/−1
- src/Development/IDE/Types/Diagnostics.hs +0/−1
- src/Development/IDE/Types/Options.hs +9/−0
- test/cabal/Development/IDE/Test/Runfiles.hs +0/−3
- test/exe/Main.hs +406/−0
+ README.md view
@@ -0,0 +1,180 @@+# `ghcide` - A library for building Haskell IDE tooling++Note: `ghcide` was previously called `hie-core`.++Our vision is that you should build an IDE by combining:+++<img style="float:right;" src="img/vscode2.png"/>++* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on;+* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages;+* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want;+* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server;+* An extension for your editor. We provide a [VS Code extension](https://code.visualstudio.com/api) as `extension` in this directory, although the components work in other LSP editors too (see below for instructions using Emacs).++There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide).++## Features++`ghcide` already exports the following features via the lsp protocol:++| Feature | LSP name |+| - | - |+| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics |+| Go to definition in local package | definition | +| Display type and source module of values | hover |+| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |+| Organize imports | codeAction (source.organizeImports) |++## Using it++### Install `ghcide`++#### With Nix++[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)++#### With Cabal or Stack++First install the `ghcide` binary using `stack` or `cabal`, e.g.++1. `git clone https://github.com/digital-asset/ghcide.git`+2. `cd ghcide`+3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`)++It's important that `ghcide` is compiled with the same compiler you use to build your projects.++### Test `ghcide`++Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end:++```+Files that worked: 152+Files that failed: 6+ * .\model\Main.hs+ * .\model\Model.hs+ * .\model\Test.hs+ * .\model\Util.hs+ * .\output\docs\Main.hs+ * .\output\docs\Part_Architecture_md.hs+Done+```++Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake.++The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project.++Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.++### Using with VS Code++Install the VS code extension (see https://code.visualstudio.com/docs/setup/mac for details on adding `code` to your `$PATH`):++1. `cd extension/`+2. `npm ci`+3. `npm run vscepackage`+4. `code --install-extension ghcide-0.0.1.vsix`++Now opening a `.hs` file should work with `ghcide`.++### Using with Emacs++If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package). Finally, add the following lines to your `.emacs`.+```elisp+;; LSP+(use-package flycheck+ :ensure t+ :init+ (global-flycheck-mode t))+(use-package yasnippet+ :ensure t)+(use-package lsp-mode+ :ensure t+ :hook (haskell-mode . lsp)+ :commands lsp)+(use-package lsp-ui+ :ensure t+ :commands lsp-ui-mode)+(use-package lsp-haskell+ :ensure t+ :config+ (setq lsp-haskell-process-path-hie "ghcide")+ (setq lsp-haskell-process-args-hie '())+ ;; Comment/uncomment this line to see interactions between lsp client/server.+ ;;(setq lsp-log-io t)+)+```++### Using with Vim/Neovim++#### LanguageClient-neovim+Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim)++Add this to your vim config:+```vim+let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml']+let g:LanguageClient_serverCommands = {+ \ 'rust': ['rls'],+ \ 'haskell': ['ghcide', '--lsp'],+ \ }+```++Refer to `:he LanguageClient` for more details on usage and configuration.++#### vim-lsp+Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp).++Add this to your vim config:++```vim+au User lsp_setup call lsp#register_server({+ \ 'name': 'ghcide',+ \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']},+ \ 'whitelist': ['haskell'],+ \ })+```++To verify it works move your cursor over a symbol and run `:LspHover`.++### coc.nvim++Install [coc.nvim](https://github.com/neoclide/coc.nvim)++Add this to your coc-settings.json (which you can edit with :CocConfig):++```json+{+ "languageserver": {+ "haskell": {+ "command": "ghcide",+ "args": [+ "--lsp"+ ],+ "rootPatterns": [+ ".stack.yaml",+ ".hie-bios",+ "BUILD.bazel",+ "cabal.config",+ "package.yaml"+ ],+ "filetypes": [+ "hs",+ "lhs",+ "haskell"+ ]+ }+ }+}+```++Here's a nice article on setting up neovim and coc: [Vim and Haskell in+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)++## History and relationship to other Haskell IDE's++The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset.++The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that has been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors.++The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).
exe/Main.hs view
@@ -9,6 +9,7 @@ import Data.List.Extra import System.FilePath import Control.Concurrent.Extra+import Control.Exception import Control.Monad.Extra import Data.Default import System.Time.Extra@@ -76,7 +77,7 @@ -- Note that this whole section needs to change once we have genuine -- multi environment support. Needs rewriting in terms of loadEnvironment. putStrLn "[1/6] Finding hie-bios cradle"- cradle <- findCradle (dir <> "/")+ cradle <- getCradle dir print cradle putStrLn "\n[2/6] Converting Cradle to GHC session"@@ -129,14 +130,24 @@ showEvent lock e = withLock lock $ print e newSession' :: Cradle -> IO HscEnvEq-newSession' cradle = getLibdir >>= \libdir -> do+newSession' cradle = do+ opts <- either throwIO return =<< getCompilerOptions "" cradle+ libdir <- getLibdir env <- runGhc (Just libdir) $ do- initializeFlagsWithCradle "" cradle+ _targets <- initSession opts getSession initDynLinker env newHscEnvEq env loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq) loadEnvironment dir = do- res <- liftIO $ newSession' =<< findCradle (dir <> "/")+ res <- liftIO $ newSession' =<< getCradle dir return $ const $ return res++getCradle :: FilePath -> IO Cradle+getCradle dir = do+ dir <- pure $ addTrailingPathSeparator dir+ mbYaml <- findCradle dir+ case mbYaml of+ Nothing -> loadImplicitCradle dir+ Just yaml -> loadCradle yaml
ghcide.cabal view
@@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide-version: 0.0.2+version: 0.0.3 license: Apache-2.0 license-file: LICENSE author: Digital Asset@@ -14,11 +14,17 @@ homepage: https://github.com/digital-asset/ghcide#readme bug-reports: https://github.com/digital-asset/ghcide/issues tested-with: GHC==8.6.5+extra-source-files: include/ghc-api-version.h README.md source-repository head type: git location: https://github.com/digital-asset/ghcide.git +flag ghc-lib+ description: build against ghc-lib instead of the ghc package+ default: False+ manual: True+ library default-language: Haskell2010 build-depends:@@ -33,9 +39,6 @@ directory, extra, filepath,- ghc-boot-th,- ghc-boot,- ghc >= 8.4, hashable, haskell-lsp-types, haskell-lsp >= 0.15,@@ -55,13 +58,22 @@ transformers, unordered-containers, utf8-string+ if flag(ghc-lib)+ build-depends:+ ghc-lib >= 8.8,+ ghc-lib-parser >= 8.8+ cpp-options: -DGHC_LIB+ else+ build-depends:+ ghc-boot-th,+ ghc-boot,+ ghc >= 8.4 if !os(windows) build-depends: unix c-sources: cbits/getmodtime.c - cpp-options: -DGHC_STABLE default-extensions: BangPatterns DeriveFunctor@@ -79,6 +91,8 @@ hs-source-dirs: src+ include-dirs:+ include exposed-modules: Development.IDE.Core.FileStore Development.IDE.Core.OfInterest@@ -99,6 +113,7 @@ other-modules: Development.IDE.Core.Debouncer Development.IDE.Core.Compile+ Development.IDE.Core.Preprocessor Development.IDE.GHC.Compat Development.IDE.GHC.CPP Development.IDE.GHC.Error@@ -113,11 +128,14 @@ Development.IDE.Spans.Calculate Development.IDE.Spans.Documentation Development.IDE.Spans.Type+ ghc-options: -Wall -Wno-name-shadowing executable ghcide+ if flag(ghc-lib)+ buildable: False default-language: Haskell2010 hs-source-dirs: exe- ghc-options: -threaded+ ghc-options: -threaded -Wall -Wno-name-shadowing main-is: Main.hs build-depends: base == 4.*,@@ -129,7 +147,7 @@ ghc-paths, ghc, haskell-lsp,- hie-bios,+ hie-bios >= 0.2, ghcide, optparse-applicative, shake,@@ -143,6 +161,8 @@ ViewPatterns test-suite ghcide-tests+ if flag(ghc-lib)+ buildable: False type: exitcode-stdio-1.0 default-language: Haskell2010 build-tool-depends:@@ -152,6 +172,14 @@ containers, extra, filepath,+ --------------------------------------------------------------+ -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas+ -- which require depending on ghc. So the tests need to depend+ -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a+ -- better solution can be found, but this is a quick solution+ -- which works for now.+ ghc,+ -------------------------------------------------------------- haskell-lsp-types, lens, lsp-test,@@ -160,7 +188,8 @@ tasty-hunit, text hs-source-dirs: test/cabal test/exe test/src- ghc-options: -threaded+ include-dirs: include+ ghc-options: -threaded -Wall -Wno-name-shadowing main-is: Main.hs other-modules: Development.IDE.Test
+ include/ghc-api-version.h view
@@ -0,0 +1,10 @@+#ifndef GHC_API_VERSION_H+#define GHC_API_VERSION_H++#ifdef GHC_LIB+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z)+#else+#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)+#endif++#endif
src/Development/IDE/Core/Compile.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}+#include "ghc-api-version.h" -- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. -- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.@@ -16,13 +17,12 @@ ) where import Development.IDE.Core.RuleTypes-import Development.IDE.GHC.CPP+import Development.IDE.Core.Preprocessor import Development.IDE.GHC.Error import Development.IDE.GHC.Warnings import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Orphans() import Development.IDE.GHC.Util-import Development.IDE.GHC.Compat import qualified GHC.LanguageExtensions.Type as GHC import Development.IDE.Types.Options import Development.IDE.Types.Location@@ -33,14 +33,12 @@ import ErrUtils import qualified GHC-import Panic import GhcMonad import GhcPlugins as GHC hiding (fst3, (<>)) import qualified HeaderInfo as Hdr import MkIface import StringBuffer as SB import TidyPgm-import qualified GHC.LanguageExtensions as LangExt import Control.Monad.Extra import Control.Monad.Except@@ -54,12 +52,8 @@ import Data.Tuple.Extra import qualified Data.Map.Strict as Map import System.FilePath-import System.IO.Extra-import Data.Char -import SysTools (Option (..), runUnlit) - -- | Given a string buffer, return a pre-processed @ParsedModule@. parseModule :: IdeOptions@@ -88,19 +82,22 @@ -- | Typecheck a single module using the supplied dependencies and packages. typecheckModule- :: HscEnv+ :: IdeDefer+ -> HscEnv -> [TcModuleResult] -> ParsedModule -> IO ([FileDiagnostic], Maybe TcModuleResult)-typecheckModule packageState deps pm =+typecheckModule (IdeDefer defer) packageState deps pm =+ let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id+ in fmap (either (, Nothing) (second Just)) $ runGhcEnv packageState $ catchSrcErrors "typecheck" $ do setupEnv deps (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->- GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm}+ GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak $ pm_mod_summary pm} tcm2 <- mkTcModuleResult tcm- return (warnings, tcm2)+ return (map unDefer warnings, tcm2) -- | Compile a single type-checked module to a 'CoreModule' value, or -- provide errors.@@ -132,9 +129,33 @@ (cg_binds tidy) (mg_safe_haskell desugar) - return (warnings, core)+ return (map snd warnings, core) +demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule+demoteTypeErrorsToWarnings =+ (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where + demoteTEsToWarns :: DynFlags -> DynFlags+ demoteTEsToWarns = (`gopt_set` Opt_DeferTypeErrors)+ . (`gopt_set` Opt_DeferTypedHoles)+ . (`gopt_set` Opt_DeferOutOfScopeVariables)++ update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary+ update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}++ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule+ update_pm_mod_summary up pm =+ pm{pm_mod_summary = up $ pm_mod_summary pm}++unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic+unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd+unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError fd+unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd+unDefer ( _ , fd) = fd++upgradeWarningToError :: FileDiagnostic -> FileDiagnostic+upgradeWarningToError (nfp, fd) = (nfp, fd{_severity = Just DsError})+ addRelativeImport :: ParsedModule -> DynFlags -> DynFlags addRelativeImport modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}@@ -232,7 +253,7 @@ { ml_hs_file = Just fp , ml_hi_file = derivedFile "hi" , ml_obj_file = derivedFile "o"-#ifndef GHC_STABLE+#if MIN_GHC_API_VERSION(8,8,0) , ml_hie_file = derivedFile "hie" #endif -- This does not consider the dflags configuration@@ -257,7 +278,7 @@ , ms_hsc_src = sourceType , ms_obj_date = Nothing , ms_iface_date = Nothing-#ifndef GHC_STABLE+#if MIN_GHC_API_VERSION(8,8,0) , ms_hie_date = Nothing #endif , ms_srcimps = [imp | (True, imp) <- imports]@@ -270,70 +291,7 @@ then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot") else (HsSrcFile , \newExt -> stem <.> newExt) --- | Run (unlit) literate haskell preprocessor on a file, or buffer if set-runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer-runLhs dflags filename contents = withTempDir $ \dir -> do- let fout = dir </> takeFileName filename <.> "unlit"- filesrc <- case contents of- Nothing -> return filename- Just cnts -> do- let fsrc = dir </> takeFileName filename <.> "literate"- withBinaryFile fsrc WriteMode $ \h ->- hPutStringBuffer h cnts- return fsrc- unlit filesrc fout- SB.hGetStringBuffer fout- where- unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)- args filein fileout = [- SysTools.Option "-h"- , SysTools.Option (escape filename) -- name this file- , SysTools.FileOption "" filein -- input file- , SysTools.FileOption "" fileout ] -- output file- -- taken from ghc's DriverPipeline.hs- escape ('\\':cs) = '\\':'\\': escape cs- escape ('\"':cs) = '\\':'\"': escape cs- escape ('\'':cs) = '\\':'\'': escape cs- escape (c:cs) = c : escape cs- escape [] = [] --- | Run CPP on a file-runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer-runCpp dflags filename contents = withTempDir $ \dir -> do- let out = dir </> takeFileName filename <.> "out"- case contents of- Nothing -> do- -- Happy case, file is not modified, so run CPP on it in-place- -- which also makes things like relative #include files work- -- and means location information is correct- doCpp dflags True filename out- liftIO $ SB.hGetStringBuffer out-- Just contents -> do- -- Sad path, we have to create a version of the path in a temp dir- -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)-- -- Relative includes aren't going to work, so we fix that by adding to the include path.- dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags-- -- Location information is wrong, so we fix that by patching it afterwards.- let inp = dir </> "___GHCIDE_MAGIC___"- withBinaryFile inp WriteMode $ \h ->- hPutStringBuffer h contents- doCpp dflags True inp out-- -- Fix up the filename in lines like:- -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"- let tweak x- | Just x <- stripPrefix "# " x- , "___GHCIDE_MAGIC___" `isInfixOf` x- , let num = takeWhile (not . isSpace) x- -- important to use /, and never \ for paths, even on Windows, since then C escapes them- -- and GHC gets all confused- = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""- | otherwise = x- stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out- -- | Given a buffer, flags, file path and module summary, produce a -- parsed module (or errors) and any parse warnings. parseFileContents@@ -342,28 +300,9 @@ -> FilePath -- ^ the filename (for source locations) -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)-parseFileContents preprocessor filename mbContents = do+parseFileContents customPreprocessor filename mbContents = do+ (contents, dflags) <- preprocessor filename mbContents let loc = mkRealSrcLoc (mkFastString filename) 1 1- contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents- let isOnDisk = isNothing mbContents-- -- unlit content if literate Haskell ending- (isOnDisk, contents) <- if ".lhs" `isSuffixOf` filename- then do- dflags <- getDynFlags- newcontent <- liftIO $ runLhs dflags filename mbContents- return (False, newcontent)- else return (isOnDisk, contents)-- dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents- (contents, dflags) <-- if not $ xopt LangExt.Cpp dflags then- return (contents, dflags)- else do- contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents- dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents- return (contents, dflags)- case unP Parser.parseModule (mkPState dflags contents loc) of PFailed _ locErr msgErr -> throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr@@ -388,7 +327,7 @@ throwE $ diagFromErrMsgs "parser" dflags $ snd $ getMessages pst dflags -- Ok, we got here. It's safe to continue.- let (errs, parsed) = preprocessor rdr_module+ let (errs, parsed) = customPreprocessor rdr_module unless (null errs) $ throwE $ diagFromStrings "parser" errs ms <- getModSummaryFromBuffer filename contents dflags parsed let pm =@@ -400,28 +339,3 @@ } warnings = diagFromErrMsgs "parser" dflags warns pure (warnings, pm)----- | This reads the pragma information directly from the provided buffer.-parsePragmasIntoDynFlags- :: GhcMonad m- => FilePath- -> SB.StringBuffer- -> m (Either [FileDiagnostic] DynFlags)-parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do- dflags0 <- getSessionDynFlags- let opts = Hdr.getOptions dflags0 contents fp- (dflags, _, _) <- parseDynamicFilePragma dflags0 opts- return dflags---- | Run something in a Ghc monad and catch the errors (SourceErrors and--- compiler-internal exceptions like Panic or InstallationError).-catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)-catchSrcErrors fromWhere ghcM = do- dflags <- getDynFlags- handleGhcException (ghcExceptionToDiagnostics dflags) $- handleSourceError (sourceErrorToDiagnostics dflags) $- Right <$> ghcM- where- ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags- sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages
+ src/Development/IDE/Core/Preprocessor.hs view
@@ -0,0 +1,134 @@+-- Copyright (c) 2019 The DAML Authors. All rights reserved.+-- SPDX-License-Identifier: Apache-2.0++module Development.IDE.Core.Preprocessor+ ( preprocessor+ ) where++import Development.IDE.GHC.CPP+import Development.IDE.GHC.Orphans()+import Development.IDE.GHC.Compat+import GHC+import GhcMonad+import StringBuffer as SB++import Data.List.Extra+import System.FilePath+import System.IO.Extra+import Data.Char+import DynFlags+import qualified HeaderInfo as Hdr+import Development.IDE.Types.Diagnostics+import Development.IDE.GHC.Error+import SysTools (Option (..), runUnlit)+import Control.Monad.Trans.Except+import qualified GHC.LanguageExtensions as LangExt+import Data.Maybe+++-- | Given a file and some contents, apply any necessary preprocessors,+-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)+preprocessor filename mbContents = do+ -- Perform unlit+ (isOnDisk, contents) <-+ if isLiterate filename then do+ dflags <- getDynFlags+ newcontent <- liftIO $ runLhs dflags filename mbContents+ return (False, newcontent)+ else do+ contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents+ let isOnDisk = isNothing mbContents+ return (isOnDisk, contents)++ -- Perform cpp+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents+ if not $ xopt LangExt.Cpp dflags then+ return (contents, dflags)+ else do+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents+ return (contents, dflags)+++isLiterate :: FilePath -> Bool+isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]+++-- | This reads the pragma information directly from the provided buffer.+parsePragmasIntoDynFlags+ :: GhcMonad m+ => FilePath+ -> SB.StringBuffer+ -> m (Either [FileDiagnostic] DynFlags)+parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do+ dflags0 <- getSessionDynFlags+ let opts = Hdr.getOptions dflags0 contents fp+ (dflags, _, _) <- parseDynamicFilePragma dflags0 opts+ return dflags+++-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set+runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runLhs dflags filename contents = withTempDir $ \dir -> do+ let fout = dir </> takeFileName filename <.> "unlit"+ filesrc <- case contents of+ Nothing -> return filename+ Just cnts -> do+ let fsrc = dir </> takeFileName filename <.> "literate"+ withBinaryFile fsrc WriteMode $ \h ->+ hPutStringBuffer h cnts+ return fsrc+ unlit filesrc fout+ SB.hGetStringBuffer fout+ where+ unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)+ args filein fileout = [+ SysTools.Option "-h"+ , SysTools.Option (escape filename) -- name this file+ , SysTools.FileOption "" filein -- input file+ , SysTools.FileOption "" fileout ] -- output file+ -- taken from ghc's DriverPipeline.hs+ escape ('\\':cs) = '\\':'\\': escape cs+ escape ('\"':cs) = '\\':'\"': escape cs+ escape ('\'':cs) = '\\':'\'': escape cs+ escape (c:cs) = c : escape cs+ escape [] = []+++-- | Run CPP on a file+runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer+runCpp dflags filename contents = withTempDir $ \dir -> do+ let out = dir </> takeFileName filename <.> "out"+ case contents of+ Nothing -> do+ -- Happy case, file is not modified, so run CPP on it in-place+ -- which also makes things like relative #include files work+ -- and means location information is correct+ doCpp dflags True filename out+ liftIO $ SB.hGetStringBuffer out++ Just contents -> do+ -- Sad path, we have to create a version of the path in a temp dir+ -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)++ -- Relative includes aren't going to work, so we fix that by adding to the include path.+ dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags++ -- Location information is wrong, so we fix that by patching it afterwards.+ let inp = dir </> "___GHCIDE_MAGIC___"+ withBinaryFile inp WriteMode $ \h ->+ hPutStringBuffer h contents+ doCpp dflags True inp out++ -- Fix up the filename in lines like:+ -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"+ let tweak x+ | Just x <- stripPrefix "# " x+ , "___GHCIDE_MAGIC___" `isInfixOf` x+ , let num = takeWhile (not . isSpace) x+ -- important to use /, and never \ for paths, even on Windows, since then C escapes them+ -- and GHC gets all confused+ = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""+ | otherwise = x+ stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
src/Development/IDE/Core/Rules.hs view
@@ -312,7 +312,8 @@ tms <- uses_ TypeCheck (transitiveModuleDeps deps) setPriority priorityTypeCheck packageState <- hscEnv <$> use_ GhcSession file- liftIO $ typecheckModule packageState tms pm+ IdeOptions{ optDefer = defer} <- getIdeOptions+ liftIO $ typecheckModule defer packageState tms pm generateCoreRule :: Rules ()
src/Development/IDE/Core/Shake.hs view
@@ -216,7 +216,7 @@ -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState {shakeDb :: ShakeDatabase- ,shakeAbort :: Var (IO ()) -- close whoever was running last+ ,shakeAbort :: MVar (IO ()) -- close whoever was running last ,shakeClose :: IO () ,shakeExtras :: ShakeExtras ,shakeProfileDir :: Maybe FilePath@@ -298,7 +298,7 @@ , shakeProgress = if reportProgress then lspShakeProgress eventer else const (pure ()) } rules- shakeAbort <- newVar $ return ()+ shakeAbort <- newMVar $ return () shakeDb <- shakeDb return IdeState{..} @@ -336,31 +336,47 @@ shakeProfile IdeState{..} = shakeProfileDatabase shakeDb shakeShut :: IdeState -> IO ()-shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do+shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. stop shakeClose +-- | This is a variant of withMVar where the first argument is run unmasked and if it throws+-- an exception, the previous value is restored while the second argument is executed masked.+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c+withMVar' var unmasked masked = mask $ \restore -> do+ a <- takeMVar var+ b <- restore (unmasked a) `onException` putMVar var a+ (a', c) <- masked b+ putMVar var a'+ pure c+ -- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception. shakeRun :: IdeState -> [Action a] -> IO (IO [a])--- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably--- not even start, which would make issues with async exceptions less problematic.-shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do- (stopTime,_) <- duration stop- logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"- bar <- newBarrier- start <- offsetTime- thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do- runTime <- start- let res' = case res of- Left e -> "exception: " <> displayException e- Right _ -> "completed"- logDebug logger $ T.pack $- "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"- signalBarrier bar res- -- important: we send an async exception to the thread, then wait for it to die, before continuing- return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)+shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =+ withMVar'+ shakeAbort+ (\stop -> do+ (stopTime,_) <- duration stop+ logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"+ bar <- newBarrier+ start <- offsetTime+ pure (start, bar))+ -- It is crucial to be masked here, otherwise we can get killed+ -- between spawning the new thread and updating shakeAbort.+ -- See https://github.com/digital-asset/ghcide/issues/79+ (\(start, bar) -> do+ thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do+ runTime <- start+ let res' = case res of+ Left e -> "exception: " <> displayException e+ Right _ -> "completed"+ logDebug logger $ T.pack $+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"+ signalBarrier bar res+ -- important: we send an async exception to the thread, then wait for it to die, before continuing+ pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar)) getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
src/Development/IDE/GHC/CPP.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#include "ghc-api-version.h" ----------------------------------------------------------------------------- --@@ -27,7 +28,7 @@ import DynFlags import Panic import FileCleanup-#ifndef GHC_STABLE+#if MIN_GHC_API_VERSION(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif @@ -136,11 +137,11 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags return $ case llvmVer of-#ifdef GHC_STABLE- Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]-#else+#if MIN_GHC_API_VERSION(8,8,0) Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+#else+ Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] #endif _ -> [] where
src/Development/IDE/GHC/Compat.hs view
@@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-}+#include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat(@@ -21,7 +22,11 @@ import DynFlags import GHC.LanguageExtensions.Type -#ifndef GHC_STABLE+#if MIN_GHC_API_VERSION(8,8,0)+import Data.List.Extra (enumerate)+#endif++#if MIN_GHC_API_VERSION(8,8,0) import HieAst import HieBin import HieTypes@@ -35,10 +40,12 @@ import Foreign.ForeignPtr +#if !MIN_GHC_API_VERSION(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len+#endif mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile mkHieFile _ _ _ = return (HieFile () [])@@ -53,7 +60,7 @@ data HieFileResult = HieFileResult { hie_file_result :: HieFile } #endif -#if __GLASGOW_HASKELL__ < 806+#if !MIN_GHC_API_VERSION(8,6,0) includePathsGlobal, includePathsQuote :: [String] -> [String] includePathsGlobal = id includePathsQuote = const []@@ -61,7 +68,7 @@ addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} #else@@ -69,9 +76,9 @@ #endif ghcEnumerateExtensions :: [Extension]-#if __GLASGOW_HASKELL__ >= 808+#if MIN_GHC_API_VERSION(8,8,0) ghcEnumerateExtensions = enumerate-#elif __GLASGOW_HASKELL__ >= 806+#elif MIN_GHC_API_VERSION(8,6,0) ghcEnumerateExtensions = [Cpp .. StarIsType] #else ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
src/Development/IDE/GHC/Error.hs view
@@ -8,6 +8,7 @@ , diagFromString , diagFromStrings , diagFromGhcException+ , catchSrcErrors -- * utilities working with spans , srcSpanToLocation@@ -23,6 +24,9 @@ import qualified FastString as FS import GHC import Bag+import DynFlags+import HscTypes+import Panic import ErrUtils import SrcLoc import qualified Outputable as Out@@ -109,6 +113,19 @@ realSpan = \case RealSrcSpan r -> Just r UnhelpfulSpan _ -> Nothing+++-- | Run something in a Ghc monad and catch the errors (SourceErrors and+-- compiler-internal exceptions like Panic or InstallationError).+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)+catchSrcErrors fromWhere ghcM = do+ dflags <- getDynFlags+ handleGhcException (ghcExceptionToDiagnostics dflags) $+ handleSourceError (sourceErrorToDiagnostics dflags) $+ Right <$> ghcM+ where+ ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags+ sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags . srcErrorMessages diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]
src/Development/IDE/GHC/Util.hs view
@@ -3,6 +3,7 @@ {-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint {-# LANGUAGE CPP #-}+#include "ghc-api-version.h" -- | GHC utility functions. Importantly, code using our GHC should never: --@@ -22,7 +23,7 @@ import Config import Data.List.Extra-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) import Fingerprint #endif import GHC@@ -72,7 +73,7 @@ runGhcEnv env act = do filesToClean <- newIORef emptyFilesToClean dirsToClean <- newIORef mempty- let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean}+ let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} ref <- newIORef env{hsc_dflags=dflags} unGhc act (Session ref) `finally` do cleanTempFiles dflags@@ -88,7 +89,7 @@ , sPlatformConstants = platformConstants , sProgramName = "ghc" , sProjectVersion = cProjectVersion-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) , sOpt_P_fingerprint = fingerprint0 #endif }
src/Development/IDE/GHC/Warnings.hs view
@@ -25,13 +25,14 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action-withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([FileDiagnostic], a)+withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- liftIO $ newVar [] oldFlags <- getDynFlags- let newAction dynFlags _ _ loc _ msg = do- let d = diagFromErrMsg diagSource dynFlags $ mkPlainWarnMsg dynFlags loc msg- modifyVar_ warnings $ return . (d:)+ let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()+ newAction dynFlags wr _ loc style msg = do+ let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg+ modifyVar_ warnings $ return . (wr_d:) setLogAction newAction res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} setLogAction $ log_action oldFlags
src/Development/IDE/Import/FindImports.hs view
@@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-}+#include "ghc-api-version.h" module Development.IDE.Import.FindImports ( locateModule@@ -68,6 +69,12 @@ -> m (Either [FileDiagnostic] Import) locateModule dflags exts doesExist modName mbPkgName isSource = do case mbPkgName of+ -- "this" means that we should only look in the current package+ Just "this" -> do+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName+ case mbFile of+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []+ Just file -> return $ Right $ FileImport file -- if a package name is given we only go look for a package Just _pkgName -> lookupInPackageDB dflags Nothing -> do@@ -102,7 +109,7 @@ { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens }-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) LookupUnusable unusable -> let unusables' = map get_unusable unusable get_unusable (m, ModUnusable r) = (moduleUnitId m, r)@@ -119,7 +126,7 @@ , fr_pkg = Nothing , fr_pkgs_hidden = [] , fr_mods_hidden = []-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) , fr_unusables = [] #endif , fr_suggestions = []
src/Development/IDE/LSP/CodeAction.hs view
@@ -2,6 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE CPP #-}+#include "ghc-api-version.h" -- | Go to the definition of a variable. module Development.IDE.LSP.CodeAction@@ -19,6 +21,8 @@ import Language.Haskell.LSP.Messages import qualified Data.Rope.UTF16 as Rope import Data.Char+import Data.Maybe+import Data.List.Extra import qualified Data.Text as T -- | Generate code actions.@@ -47,11 +51,32 @@ -- except perhaps to import instances from `Data.List' -- To import instances alone, use: import Data.List() | "The import of " `T.isInfixOf` _message+ || "The qualified import of " `T.isInfixOf` _message , " is redundant" `T.isInfixOf` _message- , let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . textAtPosition _end) contents- , let extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line- = [("Remove import", [TextEdit (if extend then Range _start (Position (_line _end + 1) 0) else _range) ""])]+ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])] +-- File.hs:52:41: error:+-- * Variable not in scope:+-- suggestAcion :: Maybe T.Text -> Range -> Range+-- * Perhaps you meant ‘suggestAction’ (line 83)+-- File.hs:94:37: error:+-- Not in scope: ‘T.isPrfixOf’+-- Perhaps you meant one of these:+-- ‘T.isPrefixOf’ (imported from Data.Text),+-- ‘T.isInfixOf’ (imported from Data.Text),+-- ‘T.isSuffixOf’ (imported from Data.Text)+-- Module ‘Data.Text’ does not export ‘isPrfixOf’.+ | renameSuggestions@(_:_) <- extractRenamableTerms _message+ = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]++-- Foo.hs:3:8: error:+-- * Found type wildcard `_' standing for `p -> p1 -> p'++ | "Found type wildcard" `T.isInfixOf` _message+ , " standing for " `T.isInfixOf` _message+ , typeSignature <- extractWildCardTypeSignature _message+ = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]+ -- File.hs:22:8: error: -- Illegal lambda-case (use -XLambdaCase) -- File.hs:22:6: error:@@ -75,21 +100,137 @@ | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts] +-- src/Development/IDE/Core/Compile.hs:58:1: error:+-- Could not find module ‘Data.Cha’+-- Perhaps you meant Data.Char (from base-4.12.0.0)+ | "Could not find module" `T.isInfixOf` _message+ , "Perhaps you meant" `T.isInfixOf` _message = let+ findSuggestedModules = map (head . T.words) . drop 2 . T.lines+ proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])+ in map proposeModule $ nubOrd $ findSuggestedModules _message++-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:+-- * Found hole: _ :: Int -> String+-- * In the expression: _+-- In the expression: _ a+-- In an equation for ‘foo’: foo a = _ a+-- * Relevant bindings include+-- a :: Int+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)+-- foo :: Int -> String+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)+-- Valid hole fits include+-- foo :: Int -> String+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)+-- show :: forall a. Show a => a -> String+-- with show @Int+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37+-- (and originally defined in ‘GHC.Show’))+-- mempty :: forall a. Monoid a => a+-- with mempty @(Int -> String)+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37+-- (and originally defined in ‘GHC.Base’)) (lsp-ui)++ | topOfHoleFitsMarker `T.isInfixOf` _message = let+ findSuggestedHoleFits :: T.Text -> [T.Text]+ findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines+ proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])+ holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message+ dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))+ selectLinesWithFits = filter ("::" `T.isInfixOf`)+ extractFitNames = map (T.strip . head . T.splitOn " :: ")+ in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message++ | "Top-level binding with no type signature" `T.isInfixOf` _message = let+ filterNewlines = T.concat . T.lines+ unifySpaces = T.unwords . T.words+ signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message+ startOfLine = Position (_line _start) 0+ beforeLine = Range startOfLine startOfLine+ title = "add signature: " <> signature+ action = TextEdit beforeLine $ signature <> "\n"+ in [(title, [action])]+ suggestAction _ _ = [] +topOfHoleFitsMarker :: T.Text+topOfHoleFitsMarker =+#if MIN_GHC_API_VERSION(8,6,0)+ "Valid hole fits include"+#else+ "Valid substitutions include"+#endif +mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit+mkRenameEdit contents range name =+ if fromMaybe False maybeIsInfixFunction+ then TextEdit range ("`" <> name <> "`")+ else TextEdit range name+ where+ maybeIsInfixFunction = do+ curr <- textInRange range <$> contents+ pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr++extractWildCardTypeSignature :: T.Text -> T.Text+extractWildCardTypeSignature =+ -- inferring when parens are actually needed around the type signature would+ -- require understanding both the precedence of the context of the _ and of+ -- the signature itself. Inserting them unconditionally is ugly but safe.+ ("(" `T.append`) . (`T.append` ")") .+ T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .+ snd . T.breakOnEnd "standing for "++extractRenamableTerms :: T.Text -> [T.Text]+extractRenamableTerms msg+ -- Account for both "Variable not in scope" and "Not in scope"+ | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg+ | otherwise = []+ where+ extractSuggestions = map getEnclosed+ . concatMap singleSuggestions+ . filter isKnownSymbol+ . T.lines+ singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited+ isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t+ getEnclosed = T.dropWhile (== '‘')+ . T.dropWhileEnd (== '’')+ . T.dropAround (\c -> c /= '‘' && c /= '’')++-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace+-- between the end of the range and the next newline), extend the range to take up the whole line.+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range+extendToWholeLineIfPossible contents range@Range{..} =+ let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents+ extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line+ in if extend then Range _start (Position (_line _end + 1) 0) else range+ -- | All the GHC extensions ghcExtensions :: Set.HashSet T.Text ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions --textAtPosition :: Position -> T.Text -> (T.Text, T.Text)-textAtPosition (Position row col) x+splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)+splitTextAtPosition (Position row col) x | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x , (preCol, postCol) <- T.splitAt col mid = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow) | otherwise = (x, T.empty) +textInRange :: Range -> T.Text -> T.Text+textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =+ case compare startRow endRow of+ LT ->+ let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine+ (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of+ [] -> ("", [])+ firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)+ maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines+ in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)+ EQ ->+ let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)+ in T.take (endCol - startCol) (T.drop startCol line)+ GT -> ""+ where+ linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text) setHandlersCodeAction :: PartialHandlers setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
src/Development/IDE/Spans/Calculate.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-}+#include "ghc-api-version.h" -- | Get information on modules, identifiers, etc. @@ -34,7 +35,7 @@ -- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore -- this U ignores that arg in 8.6, but is hidden in 8.4-#if __GLASGOW_HASKELL__ >= 806+#if MIN_GHC_API_VERSION(8,6,0) #define U _ #else #define U
src/Development/IDE/Types/Diagnostics.hs view
@@ -16,7 +16,6 @@ import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc-import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Types as LSP ( DiagnosticSeverity(..) , Diagnostic(..)
src/Development/IDE/Types/Options.hs view
@@ -7,6 +7,7 @@ module Development.IDE.Types.Options ( IdeOptions(..) , IdeReportProgress(..)+ , IdeDefer(..) , clientSupportsProgress , IdePkgLocationOptions(..) , defaultIdeOptions@@ -44,9 +45,16 @@ -- ^ the ```language to use , optNewColonConvention :: Bool -- ^ whether to use new colon convention+ , optDefer :: IdeDefer+ -- ^ Whether to defer type errors, typed holes and out of scope+ -- variables. Deferral allows the IDE to continue to provide+ -- features such as diagnostics and go-to-definition, in+ -- situations in which they would become unavailable because of+ -- the presence of type errors, holes or unbound variables. } newtype IdeReportProgress = IdeReportProgress Bool+newtype IdeDefer = IdeDefer Bool clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $@@ -63,6 +71,7 @@ ,optReportProgress = IdeReportProgress False ,optLanguageSyntax = "haskell" ,optNewColonConvention = False+ ,optDefer = IdeDefer True }
test/cabal/Development/IDE/Test/Runfiles.hs view
@@ -5,8 +5,5 @@ ( locateGhcideExecutable ) where -import System.FilePath (FilePath)-- locateGhcideExecutable :: IO FilePath locateGhcideExecutable = pure "ghcide"
test/exe/Main.hs view
@@ -2,10 +2,13 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE CPP #-}+#include "ghc-api-version.h" module Main (main) where import Control.Monad (void)+import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles@@ -26,6 +29,7 @@ closeDoc doc void (message :: Session ProgressDoneNotification) , diagnosticTests+ , codeActionTests ] @@ -81,6 +85,43 @@ , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] ) ]+ , testSession "typed hole" $ do+ let content = T.unlines+ [ "module Testing where"+ , "foo :: Int -> String"+ , "foo a = _ a"+ ]+ _ <- openDoc' "Testing.hs" "haskell" content+ expectDiagnostics+ [ ( "Testing.hs"+ , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]+ )+ ]++ , testGroup "deferral" $+ let sourceA a = T.unlines+ [ "module A where"+ , "a :: Int"+ , "a = " <> a]+ sourceB = T.unlines+ [ "module B where"+ , "import A"+ , "b :: Float"+ , "b = True"]+ bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"+ expectedDs aMessage =+ [ ("A.hs", [(DsError, (2,4), aMessage)])+ , ("B.hs", [(DsError, (3,4), bMessage)])]+ deferralTest title binding message = testSession title $ do+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding+ _ <- openDoc' "B.hs" "haskell" sourceB+ expectDiagnostics $ expectedDs message+ in+ [ deferralTest "type error" "True" "Couldn't match expected type"+ , deferralTest "typed hole" "_" "Found hole"+ , deferralTest "out of scope var" "unbound" "Variable not in scope"+ ]+ , testSession "remove required module" $ do let contentA = T.unlines [ "module ModuleA where" ] docA <- openDoc' "ModuleA.hs" "haskell" contentA@@ -180,9 +221,369 @@ , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")] ) ]+ , testSession "package imports" $ do+ let thisDataListContent = T.unlines+ [ "module Data.List where"+ , "x = 123"+ ]+ let mainContent = T.unlines+ [ "{-# LANGUAGE PackageImports #-}"+ , "module Main where"+ , "import qualified \"this\" Data.List as ThisList"+ , "import qualified \"base\" Data.List as BaseList"+ , "useThis = ThisList.x"+ , "useBase = BaseList.map"+ , "wrong1 = ThisList.map"+ , "wrong2 = BaseList.x"+ ]+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent+ _ <- openDoc' "Main.hs" "haskell" mainContent+ expectDiagnostics+ [ ( "Main.hs"+ , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")+ ,(DsError, (7, 9), "Not in scope: \8216BaseList.x\8217")+ ]+ )+ ]+ , testSession "unqualified warnings" $ do+ let fooContent = T.unlines+ [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+ , "module Foo where"+ , "foo :: Ord a => a -> Int"+ , "foo a = 1"+ ]+ _ <- openDoc' "Foo.hs" "haskell" fooContent+ expectDiagnostics+ [ ( "Foo.hs"+ -- The test is to make sure that warnings contain unqualified names+ -- where appropriate. The warning should use an unqualified name 'Ord', not+ -- sometihng like 'GHC.Classes.Ord'. The choice of redundant-constraints to+ -- test this is fairly arbitrary.+ , [(DsWarning, (2, 0), "Redundant constraint: Ord a")+ ]+ )+ ] ] +codeActionTests :: TestTree+codeActionTests = testGroup "code actions"+ [ renameActionTests+ , typeWildCardActionTests+ , removeImportTests+ , importRenameActionTests+ , fillTypedHoleTests+ , addSigActionTests+ ] +renameActionTests :: TestTree+renameActionTests = testGroup "rename actions"+ [ testSession "change to local variable name" $ do+ let content = T.unlines+ [ "module Testing where"+ , "foo :: Int -> Int"+ , "foo argName = argNme"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ [CACodeAction action@CodeAction { _title = actionTitle }]+ <- getCodeActions doc (Range (Position 2 14) (Position 2 20))+ liftIO $ "Replace with ‘argName’" @=? actionTitle+ executeCodeAction action+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "foo :: Int -> Int"+ , "foo argName = argName"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "change to name of imported function" $ do+ let content = T.unlines+ [ "module Testing where"+ , "import Data.Maybe (maybeToList)"+ , "foo :: Maybe a -> [a]"+ , "foo = maybToList"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ [CACodeAction action@CodeAction { _title = actionTitle }]+ <- getCodeActions doc (Range (Position 3 6) (Position 3 16))+ liftIO $ "Replace with ‘maybeToList’" @=? actionTitle+ executeCodeAction action+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "import Data.Maybe (maybeToList)"+ , "foo :: Maybe a -> [a]"+ , "foo = maybeToList"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "suggest multiple local variable names" $ do+ let content = T.unlines+ [ "module Testing where"+ , "foo :: Char -> Char -> Char -> Char"+ , "foo argument1 argument2 argument3 = argumentX"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))+ let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]+ expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]+ liftIO $ expectedActionTitles @=? actionTitles+ , testSession "change infix function" $ do+ let content = T.unlines+ [ "module Testing where"+ , "monus :: Int -> Int"+ , "monus x y = max 0 (x - y)"+ , "foo x y = x `monnus` y"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))+ [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]+ executeCodeAction fixTypo+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "monus :: Int -> Int"+ , "monus x y = max 0 (x - y)"+ , "foo x y = x `monus` y"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ ]++typeWildCardActionTests :: TestTree+typeWildCardActionTests = testGroup "type wildcard actions"+ [ testSession "global signature" $ do+ let content = T.unlines+ [ "module Testing where"+ , "func :: _"+ , "func x = x"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))+ let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+ , "Use type signature" `T.isInfixOf` actionTitle+ ]+ executeCodeAction addSignature+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "func :: (p -> p)"+ , "func x = x"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "multi-line message" $ do+ let content = T.unlines+ [ "module Testing where"+ , "func :: _"+ , "func x y = x + y"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))+ let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+ , "Use type signature" `T.isInfixOf` actionTitle+ ]+ executeCodeAction addSignature+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "func :: (Integer -> Integer -> Integer)"+ , "func x y = x + y"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "local signature" $ do+ let content = T.unlines+ [ "module Testing where"+ , "func :: Int -> Int"+ , "func x ="+ , " let y :: _"+ , " y = x * 2"+ , " in y"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))+ let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+ , "Use type signature" `T.isInfixOf` actionTitle+ ]+ executeCodeAction addSignature+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "func :: Int -> Int"+ , "func x ="+ , " let y :: (Int)"+ , " y = x * 2"+ , " in y"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ ]++removeImportTests :: TestTree+removeImportTests = testGroup "remove import actions"+ [ testSession "redundant" $ do+ let contentA = T.unlines+ [ "module ModuleA where"+ ]+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA+ let contentB = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "import ModuleA"+ , "stuffB = 123"+ ]+ docB <- openDoc' "ModuleB.hs" "haskell" contentB+ _ <- waitForDiagnostics+ [CACodeAction action@CodeAction { _title = actionTitle }]+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+ liftIO $ "Remove import" @=? actionTitle+ executeCodeAction action+ contentAfterAction <- documentContents docB+ let expectedContentAfterAction = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "stuffB = 123"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ , testSession "qualified redundant" $ do+ let contentA = T.unlines+ [ "module ModuleA where"+ ]+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA+ let contentB = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "import qualified ModuleA"+ , "stuffB = 123"+ ]+ docB <- openDoc' "ModuleB.hs" "haskell" contentB+ _ <- waitForDiagnostics+ [CACodeAction action@CodeAction { _title = actionTitle }]+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))+ liftIO $ "Remove import" @=? actionTitle+ executeCodeAction action+ contentAfterAction <- documentContents docB+ let expectedContentAfterAction = T.unlines+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"+ , "module ModuleB where"+ , "stuffB = 123"+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction+ ]++importRenameActionTests :: TestTree+importRenameActionTests = testGroup "import rename actions"+ [ testSession "Data.Mape -> Data.Map" $ check "Map"+ , testSession "Data.Mape -> Data.Maybe" $ check "Maybe" ] where+ check modname = do+ let content = T.unlines+ [ "module Testing where"+ , "import Data.Mape"+ ]+ doc <- openDoc' "Testing.hs" "haskell" content+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))+ let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]+ executeCodeAction changeToMap+ contentAfterAction <- documentContents doc+ let expectedContentAfterAction = T.unlines+ [ "module Testing where"+ , "import Data." <> modname+ ]+ liftIO $ expectedContentAfterAction @=? contentAfterAction++fillTypedHoleTests :: TestTree+fillTypedHoleTests = let++ sourceCode :: T.Text -> T.Text -> T.Text -> T.Text+ sourceCode a b c = T.unlines+ [ "module Testing where"+ , ""+ , "globalConvert :: Int -> String"+ , "globalConvert = undefined"+ , ""+ , "globalInt :: Int"+ , "globalInt = 3"+ , ""+ , "bar :: Int -> Int -> String"+ , "bar n parameterInt = " <> a <> " (n + " <> b <> " + " <> c <> ") where"+ , " localConvert = (flip replicate) 'x'"++ ]++ check :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> TestTree+ check actionTitle+ oldA oldB oldC+ newA newB newC = testSession (T.unpack actionTitle) $ do+ let originalCode = sourceCode oldA oldB oldC+ let expectedCode = sourceCode newA newB newC+ doc <- openDoc' "Testing.hs" "haskell" originalCode+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))+ let chosenAction = pickActionWithTitle actionTitle actionsOrCommands+ executeCodeAction chosenAction+ modifiedCode <- documentContents doc+ liftIO $ expectedCode @=? modifiedCode+ in+ testGroup "fill typed holes"+ [ check "replace hole `_` with show"+ "_" "n" "n"+ "show" "n" "n"++ , check "replace hole `_` with globalConvert"+ "_" "n" "n"+ "globalConvert" "n" "n"++#if MIN_GHC_API_VERSION(8,6,0)+ , check "replace hole `_convertme` with localConvert"+ "_convertme" "n" "n"+ "localConvert" "n" "n"+#endif++ , check "replace hole `_b` with globalInt"+ "_a" "_b" "_c"+ "_a" "globalInt" "_c"++ , check "replace hole `_c` with globalInt"+ "_a" "_b" "_c"+ "_a" "_b" "globalInt"++#if MIN_GHC_API_VERSION(8,6,0)+ , check "replace hole `_c` with parameterInt"+ "_a" "_b" "_c"+ "_a" "_b" "parameterInt"+#endif+ ]++addSigActionTests :: TestTree+addSigActionTests = let+ head = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"+ , "module Sigs where"]+ before def = T.unlines [head, def]+ after def sig = T.unlines [head, sig, def]++ def >:: sig = testSession (T.unpack def) $ do+ let originalCode = before def+ let expectedCode = after def sig+ doc <- openDoc' "Sigs.hs" "haskell" originalCode+ _ <- waitForDiagnostics+ actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))+ let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands+ executeCodeAction chosenAction+ modifiedCode <- documentContents doc+ liftIO $ expectedCode @=? modifiedCode+ in+ testGroup "add signature"+ [ "abc = True" >:: "abc :: Bool"+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"+ ]+ ---------------------------------------------------------------------- -- Utils @@ -198,6 +599,11 @@ -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. ( >> expectNoMoreDiagnostics 0.5) +pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction+pickActionWithTitle title actions = head+ [ action+ | CACodeAction action@CodeAction{ _title = actionTitle } <- actions+ , title == actionTitle ] run :: Session a -> IO a run s = withTempDir $ \dir -> do