ghcide 0.0.3 → 0.0.4

raw patch · 16 files changed

+512/−182 lines, 16 filesdep +hsloggerdep +tasty-expected-failuredep ~haskell-lspdep ~haskell-lsp-typesdep ~hie-biosPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hslogger, tasty-expected-failure

Dependency ranges changed: haskell-lsp, haskell-lsp-types, hie-bios, lsp-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• README.md +46/−17
• exe/Arguments.hs +2/−0
• exe/Main.hs +81/−40
• ghcide.cabal +12/−7
• src/Development/IDE/Core/Compile.hs +21/−8
• src/Development/IDE/Core/OfInterest.hs +1/−1
• src/Development/IDE/Core/Rules.hs +4/−40
• src/Development/IDE/Core/Service.hs +5/−2
• src/Development/IDE/Core/Shake.hs +34/−21
• src/Development/IDE/GHC/Util.hs +16/−9
• src/Development/IDE/LSP/Definition.hs +1/−1
• src/Development/IDE/LSP/Hover.hs +1/−1
• src/Development/IDE/LSP/LanguageServer.hs +7/−5
• src/Development/IDE/Types/Options.hs +1/−1
• test/exe/Main.hs +262/−29

@@ -0,0 +1,18 @@+### unreleased++### 0.0.4 (2019-10-20)++* Add a ``--version`` cli option (thanks @jacg)+* Update to use progress reporting as defined in LSP 3.15. The VSCode+  extension has also been updated and should now be making use of+  this.+* Properly declare that we should support code actions. This helps+  with some clients that rely on this information to enable code+  actions (thanks @jacg).+* Fix a race condition caused by sharing the finder cache between+  concurrent compilations.+* Avoid normalizing include dirs. This avoids issues where the same+  file ends up twice in the module graph, e.g., with different casing+  for drive letters.++### 0.0.3 (2019-09-21)

@@ -4,8 +4,7 @@  Our vision is that you should build an IDE by combining: --<img style="float:right;" src="img/vscode2.png"/>+![vscode](https://raw.githubusercontent.com/digital-asset/ghcide/master/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;@@ -22,7 +21,7 @@ | Feature | LSP name | | - | - | | Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics |-| Go to definition in local package | definition  | +| 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) |@@ -49,38 +48,41 @@  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+```console+Files that failed:  * .\model\Main.hs  * .\model\Model.hs  * .\model\Test.hs  * .\model\Util.hs  * .\output\docs\Main.hs  * .\output\docs\Part_Architecture_md.hs-Done+Completed (152 worked, 6 failed) ```  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.+If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). 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`):+You can install the VSCode extension from the [VSCode+marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide). -1. `cd extension/`-2. `npm ci`-3. `npm run vscepackage`-4. `code --install-extension ghcide-0.0.1.vsix`+### Using with Emacs -Now opening a `.hs` file should work with `ghcide`.+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). -### Using with Emacs+Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server: -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`.++ `lsp-ui`++ `eglot`++In each case, you can enable support by adding the shown lines to your `.emacs`:++#### lsp-ui+ ```elisp ;; LSP (use-package flycheck@@ -106,6 +108,15 @@ ) ``` +#### eglot++````elisp+(use-package eglot+  :ensure t+  :config+  (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp"))))+````+ ### Using with Vim/Neovim  #### LanguageClient-neovim@@ -171,9 +182,27 @@ 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/) +## Hacking on ghcide++To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,+running `stack test` will execute the test suite.++### Building the extension++For development, you can also the VSCode extension from this repository (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`.+ ## 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 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. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).  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. 

@@ -10,6 +10,7 @@     {argLSP :: Bool     ,argsCwd :: Maybe FilePath     ,argFiles :: [FilePath]+    ,argsVersion :: Bool     }  getArguments :: IO Arguments@@ -25,3 +26,4 @@       <$> switch (long "lsp" <> help "Start talking to an LSP server")       <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")       <*> many (argument str (metavar "FILES/DIRS..."))+      <*> switch (long "version" <> help "Show ghcide and GHC versions")

@@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above+{-# LANGUAGE CPP #-} -- To get precise GHC version  module Main(main) where @@ -28,15 +29,18 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types (LspId(IdInt)) import Linker-import System.Info import Data.Version import Development.IDE.LSP.LanguageServer import System.Directory.Extra as IO import System.Environment import System.IO+import System.Exit+import Paths_ghcide import Development.Shake hiding (Env) import qualified Data.Set as Set+import qualified Data.Map.Strict as Map  import GHC hiding (def) import qualified GHC.Paths@@ -47,61 +51,79 @@ getLibdir :: IO FilePath getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" +ghcideVersion :: String+ghcideVersion = "ghcide version: " <> showVersion version+             <> " (GHC: "          <> VERSION_ghc <> ")"+ main :: IO () main = do     -- WARNING: If you write to stdout before runLanguageServer     --          then the language server will not work-    hPutStrLn stderr $ "Starting ghcide (GHC v" ++ showVersion compilerVersion ++ ")"     Arguments{..} <- getArguments +    if argsVersion then putStrLn ghcideVersion >> exitSuccess+    else hPutStrLn stderr {- see WARNING above -} ghcideVersion+     -- lock to avoid overlapping output on stdout     lock <- newLock-    let logger = Logger $ \pri msg -> withLock lock $+    let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $             T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg      whenJust argsCwd setCurrentDirectory      dir <- getCurrentDirectory-    hPutStrLn stderr dir      if argLSP then do         t <- offsetTime         hPutStrLn stderr "Starting LSP server..."-        runLanguageServer def def $ \event vfs caps -> do+        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"+        runLanguageServer def def $ \getLspId event vfs caps -> do             t <- t             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t-            let options = (defaultIdeOptions $ loadEnvironment dir)+            -- very important we only call loadSession once, and it's fast, so just do it before starting+            session <- loadSession dir+            let options = (defaultIdeOptions $ return session)                     { optReportProgress = clientSupportsProgress caps }-            initialise (mainRule >> action kick) event logger options vfs+            initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs     else do-        -- 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 <- getCradle dir-        print cradle--        putStrLn "\n[2/6] Converting Cradle to GHC session"-        env <- newSession' cradle--        putStrLn "\n[3/6] Initialising IDE session"-        vfs <- makeVFSHandle-        ide <- initialise mainRule (showEvent lock) logger (defaultIdeOptions $ return $ const $ return env) vfs+        putStrLn $ "Ghcide setup tester in " ++ dir ++ "."+        putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues" -        putStrLn "\n[4/6] Finding interesting files"+        putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir         files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])         putStrLn $ "Found " ++ show (length files) ++ " files" -        putStrLn "\n[5/6] Setting interesting files"-        setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files+        putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"+        cradles <- mapM findCradle files+        let ucradles = nubOrd cradles+        let n = length ucradles+        putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]+        sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do+            let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x+            putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg+            cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x+            when (isNothing x) $ print cradle+            putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"+            cradleToSession cradle -        putStrLn "\n[6/6] Loading interesting files"+        putStrLn "\nStep 5/6: Initializing the IDE"+        vfs <- makeVFSHandle+        let cradlesToSessions = Map.fromList $ zip ucradles sessions+        let filesToCradles = Map.fromList $ zip files cradles+        let grab file = fromMaybe (head sessions) $ do+                cradle <- Map.lookup file filesToCradles+                Map.lookup cradle cradlesToSessions+        ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs++        putStrLn "\nStep 6/6: Type checking the files"+        setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files         results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files         let (worked, failed) = partition fst $ zip (map isJust results) files-        putStrLn $ "Files that worked: " ++ show (length worked)-        putStrLn $ "Files that failed: " ++ show (length failed)-        putStr $ unlines $ map ((++) " * " . snd) failed+        when (failed /= []) $+            putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed -        putStrLn "Done"+        let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+        putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"   expandFiles :: [FilePath] -> IO [FilePath]@@ -129,8 +151,9 @@     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags showEvent lock e = withLock lock $ print e -newSession' :: Cradle -> IO HscEnvEq-newSession' cradle = do++cradleToSession :: Cradle -> IO HscEnvEq+cradleToSession cradle = do     opts <- either throwIO return =<< getCompilerOptions "" cradle     libdir <- getLibdir     env <- runGhc (Just libdir) $ do@@ -139,15 +162,33 @@     initDynLinker env     newHscEnvEq env -loadEnvironment :: FilePath -> IO (FilePath -> Action HscEnvEq)-loadEnvironment dir = do-    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+loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)+loadSession dir = do+    cradleLoc <- memoIO $ \v -> do+        res <- findCradle v+        -- Sometimes we get C: and sometimes we get c:, try and normalise that+        -- e.g. see https://github.com/digital-asset/ghcide/issues/126+        return $ normalise <$> res+    session <- memoIO $ \file -> do+        c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file+        cradleToSession c+    return $ \file -> liftIO $ session =<< cradleLoc file+++-- | Memoize an IO function, with the characteristics:+--+--   * If multiple people ask for a result simultaneously, make sure you only compute it once.+--+--   * If there are exceptions, repeatedly reraise them.+--+--   * If the caller is aborted (async exception) finish computing it anyway.+memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b)+memoIO op = do+    ref <- newVar Map.empty+    return $ \k -> join $ mask_ $ modifyVar ref $ \mp ->+        case Map.lookup k mp of+            Nothing -> do+                res <- onceFork $ op k+                return (Map.insert k res mp, res)+            Just res -> return (mp, res)

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.0.3+version:            0.0.4 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset@@ -14,7 +14,7 @@ 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+extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md  source-repository head     type:     git@@ -40,8 +40,8 @@         extra,         filepath,         hashable,-        haskell-lsp-types,-        haskell-lsp >= 0.15,+        haskell-lsp-types >= 0.17,+        haskell-lsp >= 0.17,         mtl,         network-uri,         prettyprinter-ansi-terminal,@@ -57,7 +57,8 @@         time,         transformers,         unordered-containers,-        utf8-string+        utf8-string,+        hslogger     if flag(ghc-lib)       build-depends:         ghc-lib >= 8.8,@@ -138,6 +139,7 @@     ghc-options: -threaded -Wall -Wno-name-shadowing     main-is: Main.hs     build-depends:+        hslogger,         base == 4.*,         containers,         data-default,@@ -147,13 +149,14 @@         ghc-paths,         ghc,         haskell-lsp,-        hie-bios >= 0.2,+        hie-bios >= 0.2 && < 0.3,         ghcide,         optparse-applicative,         shake,         text     other-modules:         Arguments+        Paths_ghcide      default-extensions:         RecordWildCards@@ -170,6 +173,7 @@     build-depends:         base,         containers,+        directory,         extra,         filepath,         --------------------------------------------------------------@@ -182,10 +186,11 @@         --------------------------------------------------------------         haskell-lsp-types,         lens,-        lsp-test,+        lsp-test >= 0.8,         parser-combinators,         tasty,         tasty-hunit,+        tasty-expected-failure,         text     hs-source-dirs: test/cabal test/exe test/src     include-dirs: include

@@ -136,7 +136,11 @@   (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where    demoteTEsToWarns :: DynFlags -> DynFlags-  demoteTEsToWarns = (`gopt_set` Opt_DeferTypeErrors)+  -- convert the errors into warnings, and also check the warnings are enabled+  demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors)+                   . (`wopt_set` Opt_WarnTypedHoles)+                   . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables)+                   . (`gopt_set` Opt_DeferTypeErrors)                    . (`gopt_set` Opt_DeferTypedHoles)                    . (`gopt_set` Opt_DeferOutOfScopeVariables) @@ -154,11 +158,14 @@ unDefer ( _                                        , fd) = fd  upgradeWarningToError :: FileDiagnostic -> FileDiagnostic-upgradeWarningToError (nfp, fd) = (nfp, fd{_severity = Just DsError})+upgradeWarningToError (nfp, fd) =+  (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where+  warn2err :: T.Text -> T.Text+  warn2err = T.intercalate ": error:" . T.splitOn ": warning:" -addRelativeImport :: ParsedModule -> DynFlags -> DynFlags-addRelativeImport modu dflags = dflags-    {importPaths = nubOrd $ maybeToList (moduleImportPaths modu) ++ importPaths dflags}+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags+addRelativeImport fp modu dflags = dflags+    {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}  mkTcModuleResult     :: GhcMonad m@@ -193,9 +200,15 @@     -- by putting them in the finder cache.     let ims  = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss         ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims-    liftIO $ modifyIORef (hsc_FC session) $ \fc ->-        foldl' (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) fc-            $ zip ims ifrs+    -- We have to create a new IORef here instead of modifying the existing IORef as+    -- it is shared between concurrent compilations.+    prevFinderCache <- liftIO $ readIORef $ hsc_FC session+    let newFinderCache =+            foldl'+                (\fc (im, ifr) -> GHC.extendInstalledModuleEnv fc im ifr) prevFinderCache+                $ zip ims ifrs+    newFinderCacheVar <- liftIO $ newIORef $! newFinderCache+    modifySession $ \s -> s { hsc_FC = newFinderCacheVar }      -- load dependent modules, which must be in topological order.     mapM_ loadModuleHome tms

@@ -14,7 +14,6 @@     ) where  import           Control.Concurrent.Extra-import           Control.Monad.Except import Data.Hashable import Control.DeepSeq import GHC.Generics@@ -27,6 +26,7 @@ import qualified Data.Set                                 as Set import qualified Data.Text as T import Data.Tuple.Extra+import Data.Functor import           Development.Shake  import           Development.IDE.Core.Shake

@@ -23,10 +23,10 @@     getDependencies,     getParsedModule,     fileFromParsedModule,-    writeIfacesAndHie,     ) where -import           Control.Monad.Except+import Control.Monad+import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Development.IDE.Core.Compile import Development.IDE.Types.Options@@ -61,9 +61,6 @@ import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.Shake.Classes-import System.Directory-import System.FilePath-import MkIface  -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing@@ -128,39 +125,6 @@ getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) getParsedModule file = use GetParsedModule file --- | Write interface files and hie files to the location specified by the given options.-writeIfacesAndHie ::-       NormalizedFilePath -> [NormalizedFilePath] -> Action (Maybe [NormalizedFilePath])-writeIfacesAndHie ifDir files =-    runMaybeT $ do-        tcms <- usesE TypeCheck files-        fmap concat $ forM (zip files tcms) $ \(file, tcm) -> do-            session <- lift $ hscEnv <$> use_ GhcSession file-            liftIO $ writeTcm session tcm-  where-    writeTcm session tcm =-        do-            let fp =-                    fromNormalizedFilePath ifDir </>-                    (ms_hspp_file $-                     pm_mod_summary $ tm_parsed_module $ tmrModule tcm)-            createDirectoryIfMissing True (takeDirectory fp)-            let ifaceFp = replaceExtension fp ".hi"-            let hieFp = replaceExtension fp ".hie"-            writeIfaceFile-                (hsc_dflags session)-                ifaceFp-                (hm_iface $ tmrModInfo tcm)-            hieFile <--                liftIO $-                runHsc session $-                mkHieFile-                    (pm_mod_summary $ tm_parsed_module $ tmrModule tcm)-                    (fst $ tm_internals_ $ tmrModule tcm)-                    (fromJust $ tm_renamed_source $ tmrModule tcm)-            writeHieFile hieFp hieFile-            pure [toNormalizedFilePath ifaceFp, toNormalizedFilePath hieFp]- ------------------------------------------------------------ -- Rules -- These typically go from key to value and are oracles.@@ -188,8 +152,8 @@         pm <- use_ GetParsedModule file         let ms = pm_mod_summary pm         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]-        env <- hscEnv <$> useNoFile_ GhcSession-        let dflags = addRelativeImport pm $ hsc_dflags env+        env <- hscEnv <$> use_ GhcSession file+        let dflags = addRelativeImport file pm $ hsc_dflags env         opt <- getIdeOptions         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do             diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

@@ -20,14 +20,15 @@  import           Control.Concurrent.Extra import           Control.Concurrent.Async-import           Control.Monad.Except import Development.IDE.Types.Options (IdeOptions(..))+import Control.Monad import           Development.IDE.Core.FileStore import           Development.IDE.Core.OfInterest import Development.IDE.Types.Logger import           Development.Shake import Data.Either.Extra import qualified Language.Haskell.LSP.Messages as LSP+import qualified Language.Haskell.LSP.Types as LSP  import           Development.IDE.Core.Shake @@ -41,13 +42,15 @@  -- | Initialise the Compiler Service. initialise :: Rules ()+           -> IO LSP.LspId            -> (LSP.FromServerMessage -> IO ())            -> Logger            -> IdeOptions            -> VFSHandle            -> IO IdeState-initialise mainRule toDiags logger options vfs =+initialise mainRule getLspId toDiags logger options vfs =     shakeOpen+        getLspId         toDiags         logger         (optShakeProfiling options)

@@ -275,14 +275,15 @@     Failed -> b  -- | Open a 'IdeState', should be shut using 'shakeShut'.-shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler+shakeOpen :: IO LSP.LspId+          -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler           -> Logger           -> Maybe FilePath           -> IdeReportProgress           -> ShakeOptions           -> Rules ()           -> IO IdeState-shakeOpen eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do+shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do     shakeExtras <- do         globals <- newVar HMap.empty         state <- newVar HMap.empty@@ -295,29 +296,38 @@         shakeOpenDatabase             opts                 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts-                , shakeProgress = if reportProgress then lspShakeProgress eventer else const (pure ())+                , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())                 }             rules     shakeAbort <- newMVar $ return ()     shakeDb <- shakeDb     return IdeState{..} -lspShakeProgress :: (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()-lspShakeProgress sendMsg prog = do-    u <- T.pack . show . hashUnique <$> newUnique+lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()+lspShakeProgress getLspId sendMsg prog = do+    lspId <- getLspId+    u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique+    sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest+      lspId $ LSP.WorkDoneProgressCreateParams+      { _token = u }     bracket_ (start u) (stop u) (loop u)     where-        start id = sendMsg $ LSP.NotProgressStart $ LSP.fmServerProgressStartNotification-            ProgressStartParams-                { _id = id-                , _title = "Processing"-                , _cancellable = Nothing-                , _message = Nothing-                , _percentage = Nothing+        start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification+            LSP.ProgressParams+                { _token = id+                , _value = WorkDoneProgressBeginParams+                  { _title = "Processing"+                  , _cancellable = Nothing+                  , _message = Nothing+                  , _percentage = Nothing+                  }                 }-        stop id = sendMsg $ LSP.NotProgressDone $ LSP.fmServerProgressDoneNotification-            ProgressDoneParams-                { _id = id+        stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification+            LSP.ProgressParams+                { _token = id+                , _value = WorkDoneProgressEndParams+                  { _message = Nothing+                  }                 }         sample = 0.1         loop id = forever $ do@@ -325,11 +335,14 @@             p <- prog             let done = countSkipped p + countBuilt p             let todo = done + countUnknown p + countTodo p-            sendMsg $ LSP.NotProgressReport $ LSP.fmServerProgressReportNotification-                ProgressReportParams-                    { _id = id-                    , _message = Just $ T.pack $ show done <> "/" <> show todo-                    , _percentage = Nothing+            sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification+                LSP.ProgressParams+                    { _token = id+                    , _value = LSP.WorkDoneProgressReportParams+                      { _cancellable = Nothing+                      , _message = Just $ T.pack $ show done <> "/" <> show todo+                      , _percentage = Nothing+                      }                     }  shakeProfile :: IdeState -> FilePath -> IO ()

@@ -17,7 +17,7 @@     prettyPrint,     runGhcEnv,     textToStringBuffer,-    moduleImportPaths,+    moduleImportPath,     HscEnvEq, hscEnv, newHscEnvEq     ) where @@ -39,7 +39,9 @@ import StringBuffer import System.FilePath +import Development.IDE.Types.Location + ---------------------------------------------------------------------- -- GHC setup @@ -103,17 +105,22 @@           , pc_WORD_SIZE=8           } -moduleImportPaths :: GHC.ParsedModule -> Maybe FilePath-moduleImportPaths pm-  | rootModDir == "." = Just rootPathDir-  | otherwise =-    dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir)+moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath+-- The call to takeDirectory is required since DAML does not require that+-- the file name matches the module name in the last component.+-- Once that has changed we can get rid of this.+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm+    -- This happens for single-component modules since takeDirectory "A" == "."+    | modDir == "." = Just pathDir+    | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir   where     ms   = GHC.pm_mod_summary pm-    file = GHC.ms_hspp_file ms     mod'  = GHC.ms_mod ms-    rootPathDir  = takeDirectory file-    rootModDir   = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'+    -- A for module A.B+    modDir =+        takeDirectory $+        fromNormalizedFilePath $ toNormalizedFilePath $+        moduleNameSlashes $ GHC.moduleName mod'  -- | An HscEnv with equality. data HscEnvEq = HscEnvEq Unique HscEnv

@@ -24,7 +24,7 @@     :: IdeState     -> TextDocumentPositionParams     -> IO LocationResponseParams-gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do+gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do     mbResult <- case uriToFilePath' uri of         Just path -> do             logInfo (ideLogger ide) $

@@ -24,7 +24,7 @@     :: IdeState     -> TextDocumentPositionParams     -> IO (Maybe Hover)-onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = do+onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do     mbResult <- case uriToFilePath' uri of         Just (toNormalizedFilePath -> filePath) -> do           logInfo (ideLogger ide) $

@@ -41,7 +41,7 @@ runLanguageServer     :: LSP.Options     -> PartialHandlers-    -> ((FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)+    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)     -> IO () runLanguageServer options userHandlers getIdeState = do     -- Move stdout to another file descriptor and duplicate stderr@@ -120,7 +120,7 @@     where         handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do-            ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities+            ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities             _ <- flip forkFinally (const exitClientMsg) $ forever $ do                 msg <- readChan clientMsgChan                 case msg of@@ -161,6 +161,7 @@ setHandlersIgnore :: PartialHandlers setHandlersIgnore = PartialHandlers $ \_ x -> return x     {LSP.initializedHandler = none+    ,LSP.responseHandler = none     }     where none = Just $ const $ return () @@ -180,8 +181,9 @@   modifyOptions :: LSP.Options -> LSP.Options-modifyOptions x = x{LSP.textDocumentSync = Just $ tweak orig}+modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS+                   , LSP.codeActionProvider = Just $ CodeActionOptionsStatic True }     where-        tweak x = x{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}-        orig = fromMaybe tdsDefault $ LSP.textDocumentSync x+        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}+        origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x         tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing

@@ -58,7 +58,7 @@  clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $-    LSP._progress =<< LSP._window (caps :: LSP.ClientCapabilities)+    LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)  defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions defaultIdeOptions session = IdeOptions

@@ -7,8 +7,11 @@  module Main (main) where -import Control.Monad (void)+import Control.Applicative.Combinators+import Control.Monad import Control.Monad.IO.Class (liftIO)+import Data.Char (toLower)+import Data.Foldable import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles@@ -16,26 +19,93 @@ import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import System.Environment.Blank (setEnv)+import System.FilePath import System.IO.Extra+import System.Directory import Test.Tasty import Test.Tasty.HUnit-+import Test.Tasty.ExpectedFailure+import Data.Maybe  main :: IO () main = defaultMain $ testGroup "HIE"   [ testSession "open close" $ do       doc <- openDoc' "Testing.hs" "haskell" ""-      void (message :: Session ProgressStartNotification)+      void (message :: Session WorkDoneProgressCreateRequest)+      void (message :: Session WorkDoneProgressBeginNotification)       closeDoc doc-      void (message :: Session ProgressDoneNotification)+      void (message :: Session WorkDoneProgressEndNotification)+  , initializeResponseTests   , diagnosticTests   , codeActionTests+  , findDefinitionTests   ] +initializeResponseTests :: TestTree+initializeResponseTests = withResource acquire release tests where +  -- these tests document and monitor the evolution of the+  -- capabilities announced by the server in the initialize+  -- response. Currently the server advertises almost no capabilities+  -- at all, in some cases failing to announce capabilities that it+  -- actually does provide! Hopefully this will change ...+  tests :: IO InitializeResponse -> TestTree+  tests getInitializeResponse =+    testGroup "initialize response capabilities"+    [ chk "   text doc sync"             _textDocumentSync  tds+    , chk "   hover"                         _hoverProvider (Just True)+    , chk "NO completion"               _completionProvider  Nothing+    , chk "NO signature help"        _signatureHelpProvider  Nothing+    , chk "   goto definition"          _definitionProvider (Just True)+    , chk "NO goto type definition" _typeDefinitionProvider  Nothing+    , chk "NO goto implementation"  _implementationProvider  Nothing+    , chk "NO find references"          _referencesProvider  Nothing+    , chk "NO doc highlight"     _documentHighlightProvider  Nothing+    , chk "NO doc symbol"           _documentSymbolProvider  Nothing+    , chk "NO workspace symbol"    _workspaceSymbolProvider  Nothing+    , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True+    , chk "NO code lens"                  _codeLensProvider  Nothing+    , chk "NO doc formatting"   _documentFormattingProvider  Nothing+    , chk "NO doc range formatting"+                           _documentRangeFormattingProvider  Nothing+    , chk "NO doc formatting on typing"+                          _documentOnTypeFormattingProvider  Nothing+    , chk "NO renaming"                     _renameProvider  Nothing+    , chk "NO doc link"               _documentLinkProvider  Nothing+    , chk "NO color"                         _colorProvider  Nothing+    , chk "NO folding range"          _foldingRangeProvider  Nothing+    , chk "NO execute command"      _executeCommandProvider  Nothing+    , chk "NO workspace"                         _workspace  nothingWorkspace+    , chk "NO experimental"                   _experimental  Nothing+    ] where++      tds = Just (TDSOptions (TextDocumentSyncOptions+                              { _openClose = Just True+                              , _change    = Just TdSyncIncremental+                              , _willSave  = Nothing+                              , _willSaveWaitUntil = Nothing+                              , _save = Just (SaveOptions {_includeText = Nothing})}))++      nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})++      chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree+      chk title getActual expected =+        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir++  innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner+  innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c+  innerCaps  _ = error "this test only expects inner capabilities"++  acquire :: IO InitializeResponse+  acquire = run initializeResponse++  release :: InitializeResponse -> IO ()+  release = const $ pure ()++ diagnosticTests :: TestTree diagnosticTests = testGroup "diagnostics"-  [ testSession "fix syntax error" $ do+  [ testSessionWait "fix syntax error" $ do       let content = T.unlines [ "module Testing wher" ]       doc <- openDoc' "Testing.hs" "haskell" content       expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]@@ -46,10 +116,11 @@             }       changeDoc doc [change]       expectDiagnostics [("Testing.hs", [])]-  , testSession "introduce syntax error" $ do+  , testSessionWait "introduce syntax error" $ do       let content = T.unlines [ "module Testing where" ]       doc <- openDoc' "Testing.hs" "haskell" content-      void (message :: Session ProgressStartNotification)+      void (message :: Session WorkDoneProgressCreateRequest)+      void (message :: Session WorkDoneProgressBeginNotification)       let change = TextDocumentContentChangeEvent             { _range = Just (Range (Position 0 15) (Position 0 18))             , _rangeLength = Nothing@@ -57,7 +128,7 @@             }       changeDoc doc [change]       expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]-  , testSession "variable not in scope" $ do+  , testSessionWait "variable not in scope" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> Int -> Int"@@ -73,7 +144,7 @@             ]           )         ]-  , testSession "type error" $ do+  , testSessionWait "type error" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> String -> Int"@@ -85,7 +156,7 @@           , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]           )         ]-  , testSession "typed hole" $ do+  , testSessionWait "typed hole" $ do       let content = T.unlines             [ "module Testing where"             , "foo :: Int -> String"@@ -112,17 +183,18 @@         expectedDs aMessage =           [ ("A.hs", [(DsError, (2,4), aMessage)])           , ("B.hs", [(DsError, (3,4), bMessage)])]-        deferralTest title binding message = testSession title $ do+        deferralTest title binding msg = testSessionWait title $ do           _ <- openDoc' "A.hs" "haskell" $ sourceA binding           _ <- openDoc' "B.hs" "haskell"   sourceB-          expectDiagnostics $ expectedDs message+          expectDiagnostics $ expectedDs msg     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"+    [ deferralTest "type error"          "True"    "Couldn't match expected type"+    , deferralTest "typed hole"          "_"       "Found hole"+    , deferralTest "out of scope var"    "unbound" "Variable not in scope"+    , deferralTest "message shows error" "True"    "A.hs:3:5: error:"     ] -  , testSession "remove required module" $ do+  , testSessionWait "remove required module" $ do       let contentA = T.unlines [ "module ModuleA where" ]       docA <- openDoc' "ModuleA.hs" "haskell" contentA       let contentB = T.unlines@@ -137,7 +209,7 @@             }       changeDoc docA [change]       expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])]-  , testSession "add missing module" $ do+  , testSessionWait "add missing module" $ do       let contentB = T.unlines             [ "module ModuleB where"             , "import ModuleA"@@ -147,7 +219,7 @@       let contentA = T.unlines [ "module ModuleA where" ]       _ <- openDoc' "ModuleA.hs" "haskell" contentA       expectDiagnostics [("ModuleB.hs", [])]-  , testSession "cyclic module dependency" $ do+  , testSessionWait "cyclic module dependency" $ do       let contentA = T.unlines             [ "module ModuleA where"             , "import ModuleB"@@ -166,7 +238,7 @@           , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]           )         ]-  , testSession "cyclic module dependency with hs-boot" $ do+  , testSessionWait "cyclic module dependency with hs-boot" $ do       let contentA = T.unlines             [ "module ModuleA where"             , "import {-# SOURCE #-} ModuleB"@@ -182,7 +254,7 @@       _ <- openDoc' "ModuleB.hs" "haskell" contentB       _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot       expectDiagnostics []-  , testSession "correct reference used with hs-boot" $ do+  , testSessionWait "correct reference used with hs-boot" $ do       let contentB = T.unlines             [ "module ModuleB where"             , "import {-# SOURCE #-} ModuleA"@@ -207,7 +279,7 @@       _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot       _ <- openDoc' "ModuleC.hs" "haskell" contentC       expectDiagnostics []-  , testSession "redundant import" $ do+  , testSessionWait "redundant import" $ do       let contentA = T.unlines ["module ModuleA where"]       let contentB = T.unlines             [ "{-# OPTIONS_GHC -Wunused-imports #-}"@@ -221,7 +293,7 @@           , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]           )         ]-  , testSession "package imports" $ do+  , testSessionWait "package imports" $ do       let thisDataListContent = T.unlines             [ "module Data.List where"             , "x = 123"@@ -245,7 +317,7 @@             ]           )         ]-  , testSession "unqualified warnings" $ do+  , testSessionWait "unqualified warnings" $ do       let fooContent = T.unlines             [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"             , "module Foo where"@@ -263,6 +335,40 @@             ]           )         ]+    , testSessionWait "lower-case drive" $ do+          let aContent = T.unlines+                [ "module A.A where"+                , "import A.B ()"+                ]+              bContent = T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "module A.B where"+                , "import Data.List"+                ]+          uriB <- getDocUri "A/B.hs"+          Just pathB <- pure $ uriToFilePath uriB+          uriB <- pure $+              let (drive, suffix) = splitDrive pathB+              in filePathToUri (joinDrive (map toLower drive ) suffix)+          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)+          liftIO $ writeFileUTF8 pathB $ T.unpack bContent+          uriA <- getDocUri "A/A.hs"+          Just pathA <- pure $ uriToFilePath uriA+          uriA <- pure $+              let (drive, suffix) = splitDrive pathA+              in filePathToUri (joinDrive (map toLower drive ) suffix)+          let itemA = TextDocumentItem uriA "haskell" 0 aContent+          let a = TextDocumentIdentifier uriA+          sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)+          diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification+          let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)+          -- Check that if we put a lower-case drive in for A.A+          -- the diagnostics for A.B will also be lower-case.+          liftIO $ fileUri @?= uriB+          let msg = _message (head (toList diags) :: Diagnostic)+          liftIO $ unless ("redundant" `T.isInfixOf` msg) $+              assertFailure ("Expected redundant import but got " <> T.unpack msg)+          closeDoc a   ]  codeActionTests :: TestTree@@ -559,14 +665,14 @@  addSigActionTests :: TestTree addSigActionTests = let-  head = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"+  header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"                      , "module Sigs where"]-  before def     = T.unlines [head,      def]-  after  def sig = T.unlines [head, sig, def]+  before  def     = T.unlines [header,      def]+  after'  def sig = T.unlines [header, sig, def]    def >:: sig = testSession (T.unpack def) $ do     let originalCode = before def-    let expectedCode = after  def sig+    let expectedCode = after'  def sig     doc <- openDoc' "Sigs.hs" "haskell" originalCode     _ <- waitForDiagnostics     actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))@@ -584,13 +690,132 @@   , "a `haha` b = a b"       >:: "haha :: (t1 -> t2) -> t1 -> t2"   ] +findDefinitionTests :: TestTree+findDefinitionTests = let++  tst (get, check) pos targetRange title = testSession title $ do+    doc <- openDoc' "Testing.hs" "haskell" source+    found <- get doc pos+    check found targetRange++  checkDefs defs expected = do++    let ndef = length defs+    if ndef /= 1+      then let dfound n = "definitions found: " <> show n in+           liftIO $ dfound (1 :: Int) @=? dfound (length defs)+      else do+           let [Location{_range = foundRange}] = defs+           liftIO $ expected @=? foundRange++  checkHover hover expected =+    case hover of+      Nothing -> liftIO $ "hover found" @=? ("no hover found" :: T.Text)+      Just Hover{_contents = (HoverContents MarkupContent{_value = msg})+                ,_range    = mRange } ->+        let+          extractLineColFromMsg =+            T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn "Testing.hs:"+          lineCol = extractLineColFromMsg msg++          -- looks like hovers use 1-based numbering while definitions use 0-based+          -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.+          adjust Position{_line = l, _character = c} =+            Position{_line = l + 1, _character = c + 1}+        in+        case lineCol of+          [_,_] -> liftIO $ (adjust $ _start expected) @=? Position l c where [l,c] = map (read . T.unpack) lineCol+          _     -> liftIO $ ("[...]Testing.hs:<LINE>:<COL>**[...]", mRange) @=? (msg, Just expected)+      _ -> error "test not expecting this kind of hover info"++  mkFindTests tests = testGroup "get"+    [ testGroup "definition" $ mapMaybe fst tests+    , testGroup "hover"      $ mapMaybe snd tests ]++  test runDef runHover look bind title =+    ( runDef   $ tst def   look bind title+    , runHover $ tst hover look bind title ) where+      def   = (getDefinitions, checkDefs)+      hover = (getHover      , checkHover)+      --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out+  -- test run control+  yes, broken :: (TestTree -> Maybe TestTree)+  yes    = Just -- test should run and pass+  broken = Just . (`xfail` "known broken")+  cant   = Just . (`xfail` "cannot be made to work")+--  no = const Nothing -- don't run this test at all++  source = T.unlines+    -- 0123456789 123456789 123456789 123456789+    [ "{-# OPTIONS_GHC -Wmissing-signatures #-}" --  0+    , "module Testing where"                     --  1+    , "import Data.Text (Text)"                  --  2+    , "data TypeConstructor = DataConstructor"   --  3+    , "  { fff :: Text"                          --  4+    , "  , ggg :: Int }"                         --  5+    , "aaa :: TypeConstructor"                   --  6+    , "aaa = DataConstructor"                    --  7+    , "  { fff = \"\""                           --  8+    , "  , ggg = 0"                              --  9+    -- 0123456789 123456789 123456789 123456789+    , "  }"                                      -- 10+    , "bbb :: TypeConstructor"                   -- 11+    , "bbb = DataConstructor \"\" 0"             -- 12+    , "ccc :: (Text, Int)"                       -- 13+    , "ccc = (fff bbb, ggg aaa)"                 -- 14+    , "ddd :: Num a => a -> a -> a"              -- 15+    , "ddd vv ww = vv +! ww"                     -- 16+    , "a +! b = a - b"                           -- 17+    , "hhh (Just a) (><) = a >< a"               -- 18+    , "iii a b = a `b` a"                        -- 19+    -- 0123456789 123456789 123456789 123456789+    ]++  -- search locations            definition locations+  fffL4  = _start fff      ;  fff    = mkRange   4  4    4  7+  fffL8  = Position  8  4  ;+  fffL14 = Position 14  7  ;+  aaaL14 = Position 14 20  ;  aaa    = mkRange   7  0    7  3+  dcL7   = Position  7 11  ;  tcDC   = mkRange   3 23    5 16+  dcL12  = Position 12 11  ;+  xtcL5  = Position  5 11  ;  xtc    = undefined -- not clear what it should do+  tcL6   = Position  6 11  ;  tcData = mkRange   3  0    5 16+  vvL16  = Position 16 12  ;  vv     = mkRange  16  4   16  6+  opL16  = Position 16 15  ;  op     = mkRange  17  2   17  4+  opL18  = Position 18 22  ;  opp    = mkRange  18 13   18 17+  aL18   = Position 18 20  ;  apmp   = mkRange  18 10   18 11+  b'L19  = Position 19 13  ;  bp     = mkRange  19  6   19  7++  in+  mkFindTests+  --     def    hover  look   bind+  [ test yes    yes    fffL4  fff    "field in record definition"+  , test broken broken fffL8  fff    "field in record construction"+  , test yes    yes    fffL14 fff    "field name used as accessor"   -- 120 in Calculate.hs+  , test yes    yes    aaaL14 aaa    "top-level name"                -- 120+  , test broken broken dcL7   tcDC   "record data constructor"+  , test yes    yes    dcL12  tcDC   "plain  data constructor"       -- 121+  , test yes    broken tcL6   tcData "type constructor"              -- 147+  , test cant   broken xtcL5  xtc    "type constructor from other package"+  , test yes    yes    vvL16  vv     "plain parameter"+  , test yes    yes    aL18   apmp   "pattern match name"+  , test yes    yes    opL16  op     "top-level operator"            -- 123+  , test yes    yes    opL18  opp    "parameter operator"+  , test yes    yes    b'L19  bp     "name in backticks"+  ]++xfail :: TestTree -> String -> TestTree+xfail = flip expectFailBecause+ ---------------------------------------------------------------------- -- Utils   testSession :: String -> Session () -> TestTree-testSession name =-  testCase name . run .+testSession name = testCase name . run++testSessionWait :: String -> Session () -> TestTree+testSessionWait name = testSession name .       -- Check that any diagnostics produced were already consumed by the test case.       --       -- If in future we add test cases where we don't care about checking the diagnostics,@@ -605,9 +830,17 @@   | CACodeAction action@CodeAction{ _title = actionTitle } <- actions   , title == actionTitle ] +mkRange :: Int -> Int -> Int -> Int -> Range+mkRange a b c d = Range (Position a b) (Position c d)+ run :: Session a -> IO a run s = withTempDir $ \dir -> do   ghcideExe <- locateGhcideExecutable++  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56+  -- since the package import test creates "Data/List.hs", which otherwise has no physical home+  createDirectoryIfMissing True $ dir ++ "/Data"+   let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]   -- HIE calls getXgdDirectory which assumes that HOME is set.   -- Only sets HOME if it wasn't already set.